123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443 |
- 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]); },
- },
- };
|