Created
July 14, 2023 08:03
-
-
Save briandfoy/656a8986e2d998122e37486df1f1f999 to your computer and use it in GitHub Desktop.
rt_cpan_org_export - a program to export an rt.cpan.org queue to JSON
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
use v5.26; | |
use warnings; | |
=encoding utf8 | |
=head1 NAME | |
rt_cpan_org_export - grab the tickets for an rt.cpan.org queue | |
=head1 SYNOPSIS | |
% export PAUSE_USER=... | |
% export PAUSE_PASSWORD=... | |
% rt_cpan_org_export QUEUE-NAME > queue.json | |
For example, with the Net::SSH::Perl module: | |
% rt_cpan_org_export Net-SSH-Perl > net-ssh-perl.json | |
Beware letting the output go to the terminal. This output contains the | |
attachments for the tickets, which might be large blobs. | |
=head1 DESCRIPTION | |
This program grabs the tickets and related info from rt.cpan.org and turns | |
it into JSON. | |
Many CPAN distributions have moved from RT.cpan.org, the free bug tracker | |
that was the default place to report issues, to GitHub. When I take | |
over a CPAN module, I want to capture all of that and import it into | |
GitHub. Once I have the JSON, I can goof around with that. I can, for | |
example, use that JSON as the input to a GitHub issue importer. | |
=head2 JSON format | |
There are two top level keys: | |
{ | |
meta: { ... } | |
tickets: { ... } | |
} | |
The C<tickets> object has the ticket id as the key and an object as its | |
value: | |
{ | |
"1234": { | |
date | |
subject: | |
transactions: [ | |
{ ... } | |
{ ... } | |
]; | |
} | |
} | |
Try it on something small and look at what you get. | |
=head2 PAUSE credentials | |
You need a PAUSE login to use the RT REST API. See L<http://pause.perl.org>. | |
I<rt.cpan.org> uses the same credentials. Set the PAUSE_USER and PAUSE_PASSWORD | |
environment variables before you run the program. | |
=head1 AUTHOR | |
Copyright © 2023, brian d foy, [email protected] | |
=head1 LICENSE | |
You can use this code under the terms of the Artistic License 2. | |
=cut | |
use RT::Client::REST; | |
use RT::Client::REST::Ticket; | |
use Mojo::Util qw(dumper); | |
use Mojo::JSON qw(encode_json); | |
BEGIN { | |
require RT::Client::REST::Forms; | |
package RT::Client::REST::Forms; | |
no warnings; | |
# this warns for a reason I don't know, and $^W can't turn it off. | |
sub form_compose { | |
my ($forms) = @_; | |
my @text; | |
for my $form (@$forms) { | |
my ($c, $o, $k, $e) = @$form; | |
my $text = ''; | |
if ($c) { | |
$c =~ s/\n*$/\n/; | |
$text = "$c\n"; | |
} | |
if ($e) { | |
$text .= $e; | |
} | |
elsif ($o) { | |
my @lines; | |
for my $key (@$o) { | |
my ($line, $sp); | |
my @values = (ref $k->{$key} eq 'ARRAY') ? | |
@{ $k->{$key} } : | |
$k->{$key}; | |
$sp = " "x(length("$key: ")); | |
$sp = " "x4 if length($sp) > 16; | |
for my $v (@values) { | |
if ($v =~ /\n/) { | |
$v =~ s/^/$sp/gm; | |
$v =~ s/^$sp//; | |
if ($line) { | |
push @lines, "$line\n\n"; | |
$line = ''; | |
} | |
elsif (@lines && $lines[-1] !~ m/\n\n$/) { | |
$lines[-1] .= "\n"; | |
} | |
push @lines, "$key: $v\n\n"; | |
} | |
elsif ($line && | |
length($line)+length($v)-rindex($line, "\n") >= 70) | |
{ | |
$line .= ",\n$sp$v"; | |
} | |
else { | |
$line = $line ? "$line, $v" : "$key: $v"; | |
} | |
} | |
$line = "$key:" unless @values; | |
if ($line) { | |
if ($line =~ m/\n/) { | |
if (@lines && $lines[-1] !~ m/\n\n$/) { | |
$lines[-1] .= "\n"; | |
} | |
$line .= "\n"; | |
} | |
push @lines, "$line\n"; | |
} | |
} | |
$text .= join '', @lines; | |
} | |
else { | |
chomp $text; | |
} | |
push @text, $text; | |
} | |
return join "\n--\n\n", @text; | |
} | |
} | |
my $rt_dist = $ARGV[0]; | |
$rt_dist =~ s/::/-/g; # just in case they used a namespace | |
my $rt_user = $ENV{PAUSE_USER}; | |
my $rt_password = $ENV{PAUSE_PASSWORD}; | |
my $rt = RT::Client::REST->new( server => 'https://rt.cpan.org/' ); | |
my $result = eval { $rt->login( | |
username => $rt_user, | |
password => $rt_password | |
) }; | |
unless( $result ) { | |
warn <<~"HERE"; | |
Could not login to RT: $@\n" | |
Set the PAUSE_USER and PAUSE_PASSWORD environment variables | |
to set the login credentials. | |
HERE | |
exit 1; | |
} | |
my @rt_ticket_ids = $rt->search( | |
type => 'ticket', | |
query => qq{Queue = '$rt_dist'}, | |
); | |
say STDERR "There are " . @rt_ticket_ids . " tickets in $rt_dist"; | |
my %tickets = ( | |
meta => { | |
queue => $rt_dist, | |
run_date => time, | |
}, | |
tickets => {}, | |
); | |
foreach my $ticket_id ( sort { $a <=> $b } @rt_ticket_ids ) { | |
local $^W = 0; | |
my $ticket = RT::Client::REST::Ticket->new( | |
rt => $rt, | |
id => $ticket_id, | |
); | |
my $hash = $tickets{tickets}{$ticket_id} = {}; | |
$ticket->retrieve; | |
printf STDERR "%s: %s\n", $ticket->id, $ticket->subject // ''; | |
$hash->{subject} = $ticket->subject; | |
$hash->{date} = $ticket->created; | |
$hash->{url} = "https://rt.cpan.org/Ticket/Display.html?id=$ticket_id"; | |
$hash->{attachments} = []; | |
{ | |
my $search = $ticket->attachments()->get_iterator; | |
while( defined(my $obj = $search->() ) ) { | |
$obj->retrieve; | |
# this is insane. Anything on the ticket is an "attachment", | |
# so all comments and correspondences are "attachments". Those | |
# non-attachment attachments have no file name. This might be | |
# something that makes sense to RT, but why would this make | |
# sense to users when they see the web UI only lists the uploaded | |
# files as attachments. Want to see more insanity? Look at one | |
# of the response bodies. They are so bad I'd rather have XML. | |
# And why isn't the parent ID the one for the comment that | |
# added it? | |
next unless $obj->file_name; | |
my %t_hash = map { $_, $obj->$_() } qw( | |
id | |
content_type | |
file_name | |
transaction_id | |
message_id | |
parent | |
content_encoding | |
content | |
); | |
push $hash->{attachments}->@*, \%t_hash | |
} | |
} | |
# The first transaction should be the original report | |
my $iterator = $ticket->transactions()->get_iterator; | |
$hash->{transactions} = []; | |
while( defined(my $obj = $iterator->() ) ) { | |
my %t_hash = map { $_, $obj->$_() } qw( | |
id | |
parent_id | |
type | |
creator | |
created | |
content | |
old_value | |
new_value | |
description | |
); | |
$t_hash{content} = '' if( | |
! defined $t_hash{content} | |
or | |
$t_hash{content} eq "This transaction appears to have no content\n" | |
); | |
push $hash->{transactions}->@*, \%t_hash | |
} | |
} | |
say encode_json( \%tickets ); |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment