gitinfo/plugins/graph.pm

use POE;
use HTML::HTML5::Parser;
use HTML::Entities;
use HTTP::Request::Common;
use JSON;
use URI::Escape;
use XML::LibXML::XPathContext;

my $baseurl = $BotIrc::config->{graph_baseurl} // "https://gitirc.eu/g";

my $dograph = sub {
	my ($type, $text) = @_;
	BotIrc::check_ctx() or return;
	my $req = POST("$baseurl/gen.php", [type => $type, def => $text]);
	$ctx = BotIrc::ctx_frozen;

	BotHttp::request($req, sub {
		my $dom = eval { HTML::HTML5::Parser->new->parse_string(shift); };
		if ($@) {
			BotIrc::send_noise($ctx, "Graph error: parsing HTML: $@");
			return;
		}
		my $xpc = XML::LibXML::XPathContext->new($dom);
		$xpc->registerNs('x', 'http://www.w3.org/1999/xhtml');
		my @nodes = $xpc->findnodes('//x:pre[1]');
		if (@nodes) {
			my $err = $nodes[0]->textContent;
			chomp $err;
			$err =~ s/[\r\n]+/ | /g;
			BotIrc::send_noise($ctx, "Error processing graph definition: $err");
			return;
		}
		my $src = $xpc->findvalue('//x:img/@src');
		if (!defined $src) {
			BotIrc::send_noise($ctx, "Graph error: couldn't find generated image, sorry");
			return;
		}
		BotIrc::send_wisdom($ctx, "Generated graph: $baseurl/$src");
	}, sub {
		BotIrc::send_noise($ctx, "Graph error: graph generation failed: ".shift);
		return;
	});
};

# example gitgraph definition (newlines added for clarity):
# commit A[label "root" tag v0.1] B C[branch master? branch topic remote origin/master];
# commit D E F[branch master mergeto C tag v0.2];
# HEAD master;
# HEAD? master?;
# symref FOO master;
# edge B A label "stuff happened here";;
# A' B' C' D' E'[branch rebased];;
# merge J G H I
#
# "commit" is optional if the commit name starts with uppercase or digit
# keywords can be abbreviated:
# align -> a
# branch -> b
# commit -> c
# dim -> d
# dashed -> -
# dotted -> .
# edge -> e
# label -> l
# mergeto -> m
# merge -> m
# remote -> r
# symref -> s
# tag -> t
# up -> u
#
# empty definition part (e.g. ;;) splits into a new cluster which adds extra
# padding

my $gitgraph = sub {
	my $text = shift;
	BotIrc::check_ctx() or return;

	# Parse
	my @defs = split(/;/, $text);
	my $cluster = 0;
	my %nodes;
	my %edges;
	my @clusters = ([]);
	my @align;
	my @force_up;

	my $getident = sub {
		return $1 if $_[0] =~ s{^\s*([\w/.-]+'?\??)\s*}{};
		undef;
	};
	my $getstr = sub {
		return $1 if $_[0] =~ s{^\s*([\w/.-]+)\s*}{};
		return $1 if $_[0] =~ s{^\s*"([^"]*)"\s*}{};
		undef;
	};
	my $iscommit = sub {
		return $_[0] =~ /^[A-Z0-9]/;
	};
	my $isempty = sub {
		return $_[0] =~ /^\s*$/;
	};
	my $mark = sub {
		my ($full, $part) = @_;
		$full =~ s/\Q$part\E$//;
		"$full(HERE:)$part";
	};
	my $fail = sub {
		BotIrc::send_noise(".gitgraph parse error: ". shift);
		undef;
	};
	my $get_edge = sub {
		my ($id1, $id2) = @_;
		my $lookup = "$id1|$id2";
		return $edges{$lookup} if $edges{$lookup};
		$edges{$lookup} = {};
	};
	my $commit_node = sub {
		my ($id) = @_;
		my $node = $nodes{$id};
		my ($label) = ($id =~ s/\?$//r);
		if (!$node) {
			$node = {
				id => $id,
				label => $label,
				dim => $label ne $id,
				parents => [],
				orig => undef,
				type => 'commit',
				cluster => $cluster,
			};
			if ($id =~ /^(.+)'\??$/ && $nodes{$1}) {
				$node->{orig} = $1;
			} elsif ($id =~ /^(.+)'\??$/ && $nodes{"$1?"}) {
				$node->{orig} = "$1?";
			}
			push @{$clusters[$cluster]}, $node;
		}
		$nodes{$id} = $node;
	};
	my $branch_node = sub {
		my ($id, $commit) = @_;
		my $node = $nodes{$id};
		my ($label) = ($id =~ s/\?$//r);
		if (!$node) {
			$node = {
				id => $id,
				label => $label,
				dim => $label ne $id,
				parents => [$commit],
				type => 'branch',
				cluster => $cluster,
			};
			push @{$clusters[$cluster]}, $node;
		} else {
			$node->{parents} = [$commit];
		}
		$nodes{$id} = $node;
	};
	my $remote_node = sub {
		my ($id, $commit) = @_;
		my $node = $nodes{$id};
		my ($label) = ($id =~ s/\?$//r);
		if (!$node) {
			my $node = {
				id => $id,
				label => $label,
				dim => $label ne $id,
				parents => [$commit],
				type => 'remote',
				cluster => $cluster,
			};
			push @{$clusters[$cluster]}, $node;
		} else {
			$node->{parents} = [$commit];
		}
		$nodes{$id} = $node;
	};
	my $tag_node = sub {
		my ($id, $commit) = @_;
		my $node = $nodes{$id};
		my ($label) = ($id =~ s/\?$//r);
		if (!$node) {
			$node = {
				id => $id,
				label => $label,
				dim => $label ne $id,
				parents => [$commit],
				type => 'tag',
				cluster => $cluster,
			};
			push @{$clusters[$cluster]}, $node;
		} else {
			$node->{parents} = [$commit];
		}
		$nodes{$id} = $node;
	};
	my $symref_node = sub {
		my ($id, $ref) = @_;
		my $node = $nodes{$id};
		my ($label) = ($id =~ s/\?$//r);
		if (!$node) {
			$node = {
				id => $id,
				label => $label,
				dim => $label ne $id,
				parents => [$ref],
				type => 'symref',
				cluster => $cluster,
			};
			push @{$clusters[$cluster]}, $node;
		} else {
			$node->{parents} = [$ref];
		}
		$nodes{$id} = $node;
	};

	my $parse_commit = sub {
		my ($d, $bkup) = @_;
		my $id = $getident->($_[0]) or return;
		my $commit = $commit_node->($id);
		my $pre_attrs = $_[0];
		return $commit unless $_[0] =~ s/^\s*\[\s*//;

		while (1) {
			last if $_[0] =~ s/^\s*\]\s*//;
			return $fail->("unterminated attrs list: ". $mark->($bkup, $pre_attrs)) if $isempty->($_[0]);
			my $tmp_d = $_[0];
			my $cmd = $getident->($_[0]) or return $fail->("missing commit definition subcommand: ". $mark->($bkup, $_[0]));
			if ($cmd =~ /^b(ranch)?$/) {
				my $arg = $getident->($_[0]) or return $fail->("missing branch identifier: ". $mark->($bkup, $_[0]));
				$branch_node->($arg, $id);
			} elsif ($cmd =~ /^l(abel)?$/) {
				my $arg = $getstr->($_[0]) or return $fail->("missing label string: ". $mark->($bkup, $_[0]));
				$commit->{label} = $arg;
			} elsif ($cmd =~ /^m(ergeto)?$/) {
				my $arg = $getident->($_[0]) or return $fail->("missing commit identifier: ". $mark->($bkup, $_[0]));
				$commit_node->($arg);
				unshift @{$commit->{parents}}, $arg;
			} elsif ($cmd =~ /^r(emote)?$/) {
				my $arg = $getident->($_[0]) or return $fail->("missing remote identifier: ". $mark->($bkup, $_[0]));
				$remote_node->($arg, $id);
			} elsif ($cmd =~ /^t(ag)?$/) {
				my $arg = $getident->($_[0]) or return $fail->("missing tag identifier: ". $mark->($bkup, $_[0]));
				$tag_node->($arg, $id);
			} else {
				return $fail->("invalid commit definition subcommand: ". $mark->($bkup, $tmp_d));
			}
		}
		$commit;
	};

	for my $d (@defs) {
		if ($isempty->($d)) {
			$cluster++;
			push @clusters, [];
			next;
		}
		$d =~ s/^\s+//;

		my $bkup = $d;
		# hack to allow shorthand HEAD definition
		$d =~ s/^\s*(HEAD\??)\s*/symref $1 /;
		# shorthand for commit definition
		$d = "commit $d" if $iscommit->($d);
		my $cmd = $getident->($d);
		if ($cmd =~ /^a(lign)?$/) {
			my @args;
			my $tmp_d = $d;
			while (my $arg = $getident->($d)) {
				return $fail->("unknown identifier for 'align': ". $mark->($bkup, $tmp_d)) unless $nodes{$arg};
				push @args, $arg;
				$tmp_d = $d;
			}
			return $fail->("'align' needs at least two identifiers: ". $mark->($bkup, $d)) if @args < 2;
			push @align, \@args;
		} elsif ($cmd =~ /^c(ommit)?$/) {
			my $prev;
			while (my $commit = $parse_commit->($d, $bkup)) {
				push @{$commit->{parents}}, $prev->{id} if $prev;
				$prev = $commit;
			}
			return $fail->("commit list ends in junk: ". $mark->($bkup, $d)) unless $isempty->($d);
		} elsif ($cmd =~ /^e(dge)?$/) {
			my $arg1 = $getident->($d) or return $fail->("missing first identifier for edge definition: ". $mark->($bkup, $d));
			my $arg2 = $getident->($d) or return $fail->("missing second identifier for edge definition: ". $mark->($bkup, $d));
			my $edge = $get_edge->($arg1, $arg2);
			while (1) {
				my $subcmd = $getident->($d);
				last unless $subcmd;
				if ($subcmd =~ /^(dashed|-)$/) {
					$edge->{style} = 'dashed';
				} elsif ($subcmd =~ /^d(im)?$/) {
					$edge->{dim} = 1;
				} elsif ($subcmd =~ /^(dotted|\.)$/) {
					$edge->{style} = 'dotted';
				} elsif ($subcmd =~ /^l(abel)?$/) {
					my $label = $getstr->($d) or return $fail->("missing edge label: ". $mark->($bkup, $d));
					$edge->{label} = $label;
				} else {
					return $fail->("invalid subcommand for edge definition: ". $mark->($bkup, $d));
				}
			}
		} elsif ($cmd =~ /^m(erge)?$/) {
			my $main = $parse_commit->($d, $bkup) or return $fail->("merge does not attach to a valid commit: ". $mark->($bkup, $d));
			my @commits;
			while (my $commit = $parse_commit->($d, $bkup)) {
				push @commits, $commit;
			}
			return $fail->("invalid merge definition (missing enough valid parents): ". $mark->($bkup, $d)) unless @commits >= 2;
			return $fail->("merge definition ends in junk: ". $mark->($bkup, $d)) unless $isempty->($d);
			$main->{parents} = [map { $_->{id} } @commits];
		} elsif ($cmd =~ /^s(ymref)?$/) {
			my $arg = $getident->($d) or return $fail->("no valid symref provided: ". $mark->($bkup, $d));
			my $tmp_d = $d;
			my $ref = $getident->($d) or return $fail->("no valid target for symref provided: ". $mark->($bkup, $d));
			if (!$nodes{$ref}) {
				# Try parsing it as a new commit definition
				$d = $tmp_d;
				my $commit = $parse_commit->($d, $bkup);
				$ref = $commit->{id} if $commit;
			}
			unless ($nodes{$ref}) {
				return $fail->("target for symref is not a known node: ". $mark->($bkup, $tmp_d));
			}
			$symref_node->($arg, $ref);
		} elsif ($cmd =~ /^u(p)?$/) {
			my $tmp_d = $d;
			my $arg1 = $getident->($d) or return $fail->("missing base node for 'up': ". $mark->($bkup, $d));
			return $fail->("unknown base node for 'up': ". $mark->($bkup, $tmp_d)) unless $nodes{$arg1};
			$tmp_d = $d;
			my @args;
			while (my $arg = $getident->($d)) {
				return $fail->("unknown identifier for 'up': ". $mark->($bkup, $tmp_d)) unless $nodes{$arg};
				push @args, $arg;
				$tmp_d = $d;
			}
			return $fail->("'up' needs at least one node to move up: ". $mark->($bkup, $d)) if @args < 1;
			push @force_up, [$arg1, @args];
		} else {
			return $fail->("unrecognizable definition line: $bkup");
		}
	}

	my $render_attrs = sub {
		my @attrs = grep { $_ } @_;
		return '' unless @attrs;
		'['. join(', ', @attrs) .']';
	};
	my $render_node = sub {
		my $node = shift;
		my $out = qq{"$node->{id}"};
		my @common_attrs = (
			qq{label="$node->{label}"},
			qq{group="c$node->{cluster}"},
			$node->{dim} && qq{color="#00000080"},
			$node->{dim} && qq{fontcolor="#00000080"},
		);
		if ($node->{type} eq 'branch') {
			$out .= $render_attrs->(
				qq{shape="ellipse"},
				$node->{dim} ? qq{fillcolor="#ccffff"} : qq{fillcolor="#00ffff"},
				@common_attrs,
			);
		} elsif ($node->{type} eq 'commit') {
			my $ellip = $node->{label} eq '...';
			$out .= $render_attrs->(
				(@{$node->{parents}} > 1) && qq{fillcolor="#f0fcff"},
				$ellip && qq{penwidth=0},
				$ellip && qq{fillcolor="#e0e0e0"},
				@common_attrs,
			);
		} elsif ($node->{type} eq 'remote') {
			$out .= $render_attrs->(
				qq{shape="ellipse"},
				$node->{dim} ? qq{fillcolor="#ffeebb"} : qq{fillcolor="#ffbb00"},
				@common_attrs,
			);
		} elsif ($node->{type} eq 'symref') {
			$out .= $render_attrs->(
				qq{shape="diamond"},
				$node->{dim} ? qq{fillcolor="#ffffaa"} : qq{fillcolor="#ffff00"},
				@common_attrs,
			);
		} elsif ($node->{type} eq 'tag') {
			$out .= $render_attrs->(
				qq{shape="ellipse"},
				$node->{dim} ? qq{fillcolor="#ffffaa"} : qq{fillcolor="#ffff00"},
			);
		}
		$out .= ";";
		for my $p (@{$node->{parents}}) {
			my $edge_data = $edges{"$node->{id}|$p"};
			my $attrs = $render_attrs->(
				$node->{dim} && qq{color="#00000080"},
				$edge_data->{dim} && qq{color="#00000080"},
				$edge_data->{style} && qq{style="$edge_data->{style}"},
				$edge_data->{label} && qq{label="$edge_data->{label}"},
			);
			$out .= qq{"$node->{id}" -> "$p"$attrs;};
		}
		if ($node->{orig}) {
			$out .= qq{"$node->{id}" -> "$node->{orig}" [color="#00000080", dir=none, constraint=false, style=dotted];};
		}
		$out;
	};

	# generate dot data
	my $out = <<EOT;
graph [nodesep=0.2, ranksep=0.3, penwidth=0.0, packmode=clust, forcelabels=true];
node [shape=box, style="filled", fillcolor="#ffffff"];
edge [arrowsize=0.5, fontsize=10.0];
EOT
	my $cur_cluster = 0;
	for $cluster (@clusters) {
		$out .= qq[subgraph cluster$cur_cluster { margin = "15,0"; ];
		for my $node (@$cluster) {
			$out .= $render_node->($node);
		}
		$out .= "}";
		$cur_cluster++;
	}
	# Force alignment of nodes to same rank
	for my $align (@align) {
		$out .= '{ rank=same; '. join('; ', map { qq["$_"] } @$align) . '; }';
	}
	# Force ranking above a base node
	for my $up (@force_up) {
		my $arg1 = shift @$up;
		$out .= join('', map { qq{"$_" -> "$arg1" [style=invis]; } } @$up);
	}

	$dograph->('digraph', $out);
};

{
	irc_commands => {
		graph	=> sub { $dograph->('graph', $_[2]); },
		digraph	=> sub { $dograph->('digraph', $_[2]); },
		gitgraph => sub { $gitgraph->($_[2]); },
	},
};