package App::KGB::Client;
use utf8;
require v5.10.0;
use feature 'switch';
# vim: ts=4:sw=4:et:ai:sts=4
#
# KGB - an IRC bot helping collaboration
# Copyright © 2008 Martín Ferrari
# Copyright © 2009,2010,2011,2012,2013 Damyan Ivanov
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License as published by the Free Software
# Foundation; either version 2 of the License, or (at your option) any later
# version.
#
# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
# details.
#
# You should have received a copy of the GNU General Public License along with
# this program; if not, write to the Free Software Foundation, Inc., 51
# Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
use strict;
use warnings;
=head1 NAME
App::KGB::Client - relay commits to KGB servers
=head1 SYNOPSIS
use App::KGB::Client;
my $client = App::KGB::Client( <parameters> );
$client->run;
=head1 DESCRIPTION
B<App::KGB::Client> is the backend behind L<kgb-client(1)>. It handles
the repository-independent parts of sending the notifications to the KGB server,
L<kgb-bot(1)>. Details about extracting change from commits, branches and
modules is done by sub-classes specific to the version control system in use.
=head1 CONFIGURATION
The following parameters are accepted in the constructor:
=over
=item B<repo_id> I<repository name>
Short repository identifier. Will be used for identifying the repository to the
KGB daemon, which will also use this for IRC notifications. B<Mandatory>.
=item B<uri> I<URI>
URI of the KGB server. Something like C<http://some.server:port>. B<Mandatory>
either as a top-level parameter or as a sub-parameter of B<servers> array.
=item B<proxy> I<URI>
URI of the SOAP proxy. If not given, it is the value of the B<uri> option, with
C<?session=KGB> added.
=item B<password> I<password>
Password for authentication to the KGB server. B<Mandatory> either as a
top-level parameter or as a sub-parameter of B<servers> array.
=item B<timeout> I<seconds>
Timeout for server communication. Default is 15 seconds, as we want instant IRC
and commit response.
=item B<servers>
An array of servers, each an instance of L<App::KGB::Client::ServerRef> class.
When several servers are configured, the list is shuffled and then the servers
are tried one after another until a successful request is done, or the list is
exhausted, in which case an exception is thrown.
When shuffling, preference is added to the last server used by the client, or
by other clients (given C<status_dir> is configured).
=item B<batch_messages>
If true, the notifications are sent as a batch in one request to the server.
Useful with VCS that send many changes a time (e.g. Git).
Defaults to false, but will be changed later after some grace period for server
upgrade.
=item B<br_mod_re>
A list of regular expressions (simple strings, not L<qr> objects) that serve
for detection of branch and module of commits. Each item from the list is tried
in turn, until an item is found that matches all the paths that were modified
by the commit. Regular expressions must have two captures: the first one giving
the branch name, and the second one giving the module name.
All the paths that were modified by the commit must resolve to the same branch
and module in order for the branch and module to be transmitted to the KGB
server.
Example: ^/(trunk)/([^/]+)/
# /trunk/module/file
^/branches/([^/]+)/([^/]+)/
# /branches/test/module/file
=item B<mod_br_re>
Same as B<br_mod_re>, but captures module name first and branch name second.
Example: ^/branches/([^/]+)/([^/]+)/
# /branches/test/module/file
=item B<ignore_branch>
When most of the development is in one branch, transmitting it to the KGB
server and seeing it on IRC all the time can be annoying. Therefore, if you
define B<ignore_branch>, and a given commit is in a branch with that name, the
branch name is not transmitted to the server. Module name is still transmitted.
=item B<module>
Forces explicit module name, overriding the branch and module detection. Useful
in Git-hosted sub-projects that want to share single configuration file, but
still want module indication in notifications.
=item B<single_line_commits> I<off|forced|auto>
Request different modes of commit message processing:
=over
=item I<off>
No processing is done. The commit message is printed as was given, with each
line in a separate IRC message, blank lines omitted. This is the only possible
behaviour in versions before 1.14.
=item I<forced>
Only the first line is sent to IRC, regardless of whether it is followed by a
blank line or not.
=item I<auto>
If the first line is followed by an empty line, only the first line is sent to
IRC and the rest is ignored. This is the default since version 1.14.
=back
=item B<use_irc_notices>
If true signals the server that it should use IRC notices instead of regular
messages. Use this if regular messages are too distracting for your channel.
=item B<use_color>
If true (the default) signals the server that it should use colors for commit
notifications.
=item B<status_dir>
Specifies a directory to store information about the last server contacted
successfully. The client would touch files in that directory after successful
completion of a notification with remote server.
Later, when asked to do another notification, the client would start from the
most recently contacted server. If that was contacted too far in the past, the
information in the directory is ignored and a random server is picked, as
usual.
=item B<verbose>
Print diagnostic information.
=item B<protocol> I<version>
Use specified protocol version. If C<auto> (the default), the version of the
protocol C<2>, unless B<web_link> is also given, in which case protocol version
C<3> is default;
=item B<web_link> I<template>
A web link template to be sent to the server. The following items are expanded:
=over
=item ${branch}
=item ${module}
=item ${commit}
=item ${project}
=back
=item B<short_url_service> I<service>
A L<WWW::Shorten> service to use for shortening the B<web_link>. See
L<WWW::Shorten> for the list of supported services.
=item msg_template I<string>
Provides a way to customize the notifications' appearance on IRC. When present,
all message construction is done on the client and the prepared messages
(possibly with colors etc) are sent to the server for relaying to IRC.
The following special items are recognized and replaced with the respective
commit elements.
=over
=item ${project_id}
The ID of the project.
=item ${author_login}
The login of the author (e.g. "joe").
=item ${author_name}
The name of the commit author (e.g. "Joe Random")
=item ${branch}
The branch of the commit.
=item ${module}
The module of the commit.
=item ${commit}
=item ${revision}
The ID of the commit.
=item ${path}
The changed path(s).
=item ${log}
The log message of the commit.
=item ${web}
The web link associated with the commit. Replaced with the empty string unless
the B<web_link> option is also given.
=back
=item style I<hash reference>
Provides a color map for different parts of the message. The following keys are
supported. Defaults are used when keys are missing in the hash. B<use_color>
must be true for this to have any effect. Used only when B<msg_template> is
also given.
=over
=item revision
=item commit_id
Commit ID. Default: none.
=item path
Changed path. Default: teal.
Depending on the action performed to the path, additional coloring is made:
=over
=item addition
Used for added paths. Default: green.
=item modification
Used for modified paths. Default: teal.
=item deletion
Used for deleted paths. Default: bold red.
=item replacement
Used for replaced paths (a Subversion concept). Default: brown.
=item prop_change
Used for paths with changed properties (a Subversion concept), combined with
other colors depending on the action -- addition, modification or replacement.
Default: underline.
=back
=item author
Commit author. Default: green.
=item branch
Commit branch. Default: brown.
=item module
Project module. Default: purple.
=item web
URL to commit information. Default: silver.
=item separator
The separator before the commit log. Default: none.
=back
=back
=cut
require v5.10.0;
use Carp qw(confess);
use Digest::MD5 qw(md5_hex);
use Digest::SHA qw(sha1_hex);
use DirHandle ();
use SOAP::Lite;
use Getopt::Long;
use List::Util ();
use User::pwent;
use YAML ();
use base 'Class::Accessor::Fast';
__PACKAGE__->mk_accessors(
qw( repo_id servers br_mod_re mod_br_re module ignore_branch
single_line_commits use_irc_notices use_color status_dir verbose protocol
web_link short_url_service _last_server
msg_template
style colors painter
batch_messages
_full_user_name
)
);
=head1 CONSTRUCTOR
=head2 new ( { I<initial values> } )
Standard constructor with initial values in a hashref.
my $c = App::KGB::Client->new(
{ repo_id => 'my-repo',
servers => \@servers,
...
}
);
See L<|FIELDS> above.
=cut
sub new {
my ( $class, $init ) = @_;
my $self = $class->SUPER::new(
{ use_color => 1,
%$init,
}
);
print "Configuration: " . YAML::Dump(@_) if $self->verbose;
defined( $self->repo_id )
or confess "'repo_id' is mandatory";
$self->br_mod_re( [ $self->br_mod_re // () ] )
if not ref( $self->br_mod_re );
$self->mod_br_re( [ $self->mod_br_re // () ] )
if not ref( $self->mod_br_re );
$self->servers( [] ) unless defined( $self->servers );
ref( $self->servers ) and ref( $self->servers ) eq 'ARRAY'
or confess "'servers' must be an arrayref";
@{ $self->servers } or confess "No 'servers' specified";
if ( $self->status_dir ) {
if ( not -e $self->status_dir ) {
warn "Status directory ".$self->status_dir." doesn't exist.\n";
$self->status_dir(undef);
}
elsif ( not -d $self->status_dir ) {
warn $self->status_dir." is not a directory\n";
$self->status_dir(undef);
}
}
$self->protocol('auto') unless defined( $self->protocol );
return $self;
}
=head1 METHODS
=over
=item detect_branch_and_module ( $changes )
Given a set of changes (an arrayref of L<App::KGB::Change> objects), runs all
the regular expressions as listed in B<br_mod_re> and B<mod_br_re> and if a
regular expression that matches all the changed paths and returns the branch
and module.
( $branch, $module ) = $client->detect_branch_and_module($changes);
=cut
sub _run_matches {
my ( $safe, $changes, $res, $swap ) = @_;
for my $re (@$res) {
$re =~ s{,}{\\,}g; # escape commas
my $matching = "m,$re,; " . ( $swap ? '($2,$1)' : '($1,$2)' );
local $_ = $changes->path;
my ( $branch, $module ) = $safe->reval($matching);
die "Error while evaluating `$re': $@" if $@;
if ( defined($branch) and defined($module) ) {
return ( $re, $branch, $module );
}
}
return ( undef, undef, undef );
}
sub detect_branch_and_module {
my ( $self, $changes ) = @_;
return () unless $self->br_mod_re;
require Safe;
my $safe = Safe->new;
$safe->permit_only(
qw(padany lineseq match const leaveeval
rv2sv pushmark list warn)
);
my ( $branch, $module, $matched_re );
# for a successful branch/module extraction, we require that all the
# changes share the same branch/module
for my $c (@$changes) {
my ( $change_branch, $change_module );
( $matched_re, $change_branch, $change_module )
= _run_matches( $safe, $c, $self->br_mod_re, 0 );
( $matched_re, $change_branch, $change_module )
= _run_matches( $safe, $c, $self->mod_br_re, 1 )
unless $matched_re
and defined($change_branch)
and defined($change_module);
# some change cannot be tied to a branch and a module?
if ( !defined( $change_branch // $change_module ) ) {
$branch = $module = $matched_re = undef;
last;
}
if ( defined($branch) ) {
# this change is for a different branch/module?
if ( $branch ne $change_branch or $module ne $change_module ) {
$branch = $module = $matched_re = undef;
last;
}
}
else {
# first change, store branch and module
$branch = $change_branch;
$module = $change_module;
}
}
# remove the part that have matched as it contains information about the
# branch and module that we provide otherwise
if ($matched_re) {
#warn "Branch: ".($branch||"NONE");
#warn "Module: ".($module||"NONE");
$safe->permit(qw(subst));
for my $c (@$changes) {
#warn "FROM ".$c->{path};
$_ = $c->path;
$safe->reval("s,.*$matched_re,,");
die "Eror while evaluating s/.*$matched_re//: $@" if $@;
$c->path($_);
#warn " TO $_";
}
}
if ( $self->verbose and $branch ) {
print "Detected branch '$branch' and module '"
. ( $module // 'NONE' ) . "'\n";
}
return ( $branch, $module );
}
=item shuffle_servers
Returns a shuffled variant of C<< $self->servers >>. It considers the last
successfuly used server by this client instance and puts it first. If there is
no such server, it considers the state in C<status_dir> and picks the last
server noted there, if it was used in the last 5 minutes.
=cut
sub shuffle_servers {
my $self = shift;
my @servers = List::Util::shuffle( @{ $self->servers } );
if ( $self->_last_server ) {
# just put the last server first in the list
@servers = sort {
return -1 if $a->uri eq $self->_last_server->uri;
return +1 if $b->uri eq $self->_last_server->uri;
return 0;
} @servers;
}
elsif ( $self->status_dir ) {
# pick a server from the status directory
my %hashes;
do {
my $i = 0;
for (@servers) {
$hashes{ md5_hex( $_->uri ) } = $i++;
}
};
my $d = DirHandle->new( $self->status_dir );
my $latest_stamp;
my $latest_hash;
if ( defined $d ) {
my $now = time;
while( defined( my $f = $d->read ) ) {
next
unless $f =~ /^kgb-client.([0-9a-f]+)$/
and exists( $hashes{$1} );
my $file = File::Spec->catdir($self->status_dir, $f);
my $stamp = (stat $file)[9];
if ( $latest_stamp ) {
if( $latest_stamp < $stamp ) {
$latest_stamp = $stamp;
$latest_hash = $1;
}
}
elsif ( $stamp >= ( $now - 300 ) ) {
# accessed in the last 5 minutes, consider it
$latest_stamp = $stamp;
$latest_hash = $1;
}
}
if ( $latest_stamp ) {
my $winner = splice( @servers, $hashes{$latest_hash}, 1 );
unshift @servers, $winner;
}
}
else {
warn "Unable to read directory ".$self->status_dir."\n";
$self->status_dir(undef);
}
}
return @servers;
}
=item expand_link ($string, \%data)
Expands items in the form I<${item}> in I<$string>, using the data in the
supplied hash reference.
Passing
"http://git/${module}.git?commit=${commit}",
{ module => 'dh-make-perl', commit => '225ceca' }
would result in C<http://git/dh-make-perl.git?commit=225ceca>.
=cut
sub expand_link {
my ( $self, $input, $data ) = @_;
my $output = '';
my $re = qr/\$\{([^{}]+)\}/p;
while ( $input =~ $re ) {
my $f = $1;
my $v;
if ( exists $data->{$f} ) {
$v = $data->{$f} // '';
}
else {
$v = '';
warn "Unknown substitution '$f'\n";
}
$output .= ${^PREMATCH} . $v;
$input = ${^POSTMATCH};
}
warn "Web link expanded to $output\n" if $self->verbose;
return $output;
}
=item shorten_url (url)
Uses the configured I<short_url_service> to shorten the given URL. If no
shortening service is configured, the original URL is returned.
=cut
sub shorten_url {
my ( $self, $url ) = @_;
return $url unless my $service = $self->short_url_service;
my $ok = eval {
require WWW::Shorten;
WWW::Shorten->import( $service, ':short' );
1;
};
unless ($ok) {
warn "Unable to load URL shortening service '$service': $@";
warn "Sending plain URL.\n";
return $url;
}
my $short_url = short_link($url);
return $short_url if defined($short_url);
warn "URL shortening service '$service' failed.\n";
warn "Sending plain URL.\n";
return $url;
}
=item note_last_server($srv)
If C<status_dir> is configured, notes $srv as the last used server to be used
in subsequent requests.
=cut
sub note_last_server {
my ( $self, $srv ) = @_;
return unless $self->status_dir;
require File::Touch;
File::Touch::touch(
File::Spec->catfile(
$self->status_dir,
sprintf( "kgb-client.%s", md5_hex( $srv->uri ) )
)
);
}
use constant rev_prefix => '';
=item init_painter
Creates an internal instance of L<App::KGB::Painter> used to color message
elements.
Does nothing if I<use_color> is false or if painter has been already created.
=cut
sub init_painter {
my $self = shift;
return unless $self->use_color;
return if $self->painter;
require App::KGB::Painter;
$self->painter(
App::KGB::Painter->new( { item_colors => $self->colors } ) );
}
=item colorize I<category> => I<text>
Returns a colored version of I<text>. If there is no painter, returns just
I<text>.
=cut
sub colorize {
my ( $self, $category, $text ) = @_;
return $text unless $self->painter;
return $self->painter->colorize( $category => $text );
}
our %action_styles = (
A => 'addition',
M => 'modification',
D => 'deletion',
R => 'replacement',
);
=item colorize_change I<change>
returns a colorized string representing a single change
=cut
sub colorize_change {
my ( $self, $c ) = @_;
my $action_style = $action_styles{ $c->action };
my $text = $self->colorize( $action_style => $c->path );
$text = $self->colorize( 'prop_change' => $text ) if $c->prop_change;
return $text;
}
our $MAGIC_MAX_FILES = 4;
=item colorize_changes \@changes
returns a colorized string of all commit's changes
=cut
sub colorize_changes {
my ( $self, $changes ) = @_;
my $changed_files = scalar @$changes;
if ( $changed_files > $MAGIC_MAX_FILES ) {
my %dirs;
for my $c (@$changes) {
my $dir = dirname( $c->path );
$dirs{$dir}++;
}
my $dirs = scalar( keys %dirs );
my $path_string = join( ' ',
( $dirs > 1 )
? sprintf( "(%d files in %d dirs)", $changed_files, $dirs )
: sprintf( "(%d files)", $changed_files ) );
return $self->colorize( path => $path_string );
}
elsif ($changed_files) {
return join( ' ', map { $self->colorize_change($_) } @$changes );
}
else {
return '';
}
}
=item format_message %details
Returns a formatted message, ready to be sent to the servers. The message is
formatted according to the B<message_format> configuration parameter, honouring
B<colors> and B<use_color>.
=cut
sub format_message {
my ( $self, $msg, %p ) = @_;
my $commit = $p{commit};
$self->init_painter;
my $result = '';
warn "# msg = '$msg'" if 0;
while ( $msg =~ /\$\{([^{}]+)?\{([^{}]+)\}([^{}]+)?\}/ps ) {
my ( $pre, $token, $post ) = ( $1, $2, $3 );
warn "# pre = '$pre' token = '$token' post = '$post'" if 0;
$result .= ${^PREMATCH};
$msg = ${^POSTMATCH};
warn "# msg is now '$msg'" if 0;
my @r;
given ($token) {
when ('project') { push @r, project => $self->repo_id }
when ('author-login') {
push @r, author => $commit
? $commit->author
: $p{author_login}
}
when ('author-name') {
push @r, author => $commit
? $commit->author_name
: $p{author_name}
}
when ('branch') {
push @r, branch => $commit ? $commit->branch : $p{branch}
}
when ('module') {
push @r, module => $self->module
// ( $commit ? $commit->module : $p{module} )
}
when ('web-link') { push @r, web => $p{web_link} }
when ('commit') {
push @r, commit_id => $commit ? $commit->id : $p{commit_id}
}
when ('log') { push @r, log => $commit ? $commit->log : $p{log} }
when ('log-first-line') {
push @r, log => ( split( /\n/, $commit->log ) )[0]
}
when ('changes') {
push @r, '' => $self->colorize_changes( $commit->changes )
if $commit and $commit->changes;
}
default {
push @r, '' => "Unknown item '$_'"
}
}
my ( $category, $item ) = @r;
warn "# item = '$item'" if 0;
next unless defined($item) and $item ne '';
$result .= $pre // '';
$result .=
( $category eq '' )
? $item
: $self->colorize( $category => $item );
$result .= $post // '';
}
$result .= $msg;
return $result;
}
=item process_commit ($commit)
Processes a single commit, returning something for sending to the remote
server. I<Something> is either a reference to array of arguments to be passed
to L<App::KGB::ServerRef>'s send_changes method, or, in message-relay mode, a
plain scalar string representing the commit.
If $commit is a plain scalar (not a reference), then it is assumed to be an
already processed string and is returned directly.
=cut
sub process_commit {
my ( $self, $commit ) = @_;
# plain strings are already processed by the VCS-specific module
return $commit unless ref($commit);
my $module = $self->module // $commit->module;
my $branch = $commit->branch;
if ( not defined($module) or not defined($branch) ) {
my ( $det_branch, $det_module )
= $self->detect_branch_and_module( $commit->changes );
$branch //= $det_branch;
$module //= $det_module;
}
my $web_link = $self->web_link;
if ( defined($web_link) ) {
$web_link = $self->expand_link(
$web_link,
{ branch => $branch,
module => $module,
commit => $commit->id,
project => $self->repo_id
}
);
$web_link = $self->shorten_url($web_link);
}
$branch = undef
if $branch and $branch eq ( $self->ignore_branch // '' );
# All data prepared. Now, how do we represent this commit?
# A pre-formatted, pre-coloured string, if msg_template is configured
return $self->format_message(
$self->msg_template,
commit => $commit,
branch => $branch,
module => $module,
web_link => $web_link
) if $self->msg_template;
# otherwise, prepare things for send_changes()
my @args = ( $commit, $branch, $module );
my %extra;
$extra{web_link} = $web_link if defined($web_link);
$extra{use_irc_notices} = $self->use_irc_notices
if $self->use_irc_notices;
$extra{use_color} = $self->use_color;
push @args, \%extra if %extra;
return \@args;
}
=item process
The main processing method. Calls B<describe_commit> and while it returns true
values, gives them to B<process_commit> and send the result to the server.
If B<batch_messages> flag is true, relays accumulated messages after
processing.
=cut
sub process {
my $self = shift;
my @messages;
while ( my $commit = $self->describe_commit ) {
my $data = $self->process_commit($commit);
if (ref($data)) {
# a structure to be interpreted by the server
$self->send_changes($data);
}
else {
# a plain string
if ( $self->batch_messages ) {
# batch it, will send the whole batch in one transaction below
push @messages, $data;
}
else {
# relay immediately
$self->relay_message($data);
}
}
}
$self->relay_message( \@messages ) if $self->batch_messages and @messages;
}
=item send_changes \@args
Tries to send the changes described in the given array reference to all
configured servers.
=cut
sub send_changes {
my ( $self, $args ) = @_;
my @servers = $self->shuffle_servers;
# try all servers in turn until someone succeeds
my $failure;
for my $srv (@servers) {
$failure = eval {
$srv->send_changes( $self, $self->protocol, @$args );
$self->_last_server($srv);
$self->note_last_server($srv);
0;
} // 1;
warn $@ if $failure;
last unless $failure;
}
die "Unable to complete notification. All servers failed\n"
if $failure;
}
=item relay_message I<message>
Send a simple message to servers for relaying. Implements the --relay-msg
command line option.
=cut
sub relay_message {
my $self = shift;
my $msg = shift // die "Syntax: \$client->relay_message(msg)";
my @servers = $self->shuffle_servers;
# try all servers in turn until someone succeeds
my $failure;
for my $srv (@servers) {
$failure = eval {
$srv->relay_message( $self, $msg,
{ use_irc_notices => $self->use_irc_notices } );
$self->_last_server($srv);
$self->note_last_server($srv);
0;
} // 1;
warn $@ if $failure;
last unless $failure;
}
die "Unable to relay message. All servers failed\n"
if $failure;
}
sub _get_full_user_name {
my $self = shift;
my $login = shift // $ENV{USER};
return $self->_full_user_name if $self->_full_user_name;
my $user = getpwnam($login);
( my $full_name = $user->gecos ) =~ s/,.*//;
$self->_full_user_name($full_name);
return $full_name;
}
1;
__END__
=back
=head1 PROVIDING REPOSITORY-SPECIFIC FUNCTIONALITY
L<App::KGB::Client> is a generic class providing repository-agnostic
functionality. All repository-specific methods are to be provided by classes,
inheriting from L<App::KGB::Client>. See L<App::KGB::Client::Subversion> and
L<App::KGB::Client::Git>.
Repository classes must provide the following method:
=over
=item B<dsescribe_commit>
This method returns an L<App::KGB::Commit> object that
represents a single commit of the repository.
B<describe_commit> is called several times, until it returns C<undef>. The idea
is that a single L<App::KGB::Client> run can be used to process several commits
(for example if the repository is L<git(1)>). If this is the case each call to
B<describe_commit> shall return information about the next commit in the
series. For L<svn(1)>, this module is expected to return only one commit,
subsequent calls shall return C<undef>.
=back
=head1 SEE ALSO
=over
=item L<App::KGB::Client::Subversion>
=item L<App::KGB::Client::Git>
=back
=cut