363 lines
11 KiB
Perl
363 lines
11 KiB
Perl
|
|
=head1 SQL Schema
|
|
|
|
CREATE TABLE $p (
|
|
id integer PRIMARY KEY AUTOINCREMENT NOT NULL,
|
|
issue integer NOT NULL,
|
|
date integer NOT NULL,
|
|
name text DEFAULT '' NOT NULL,
|
|
email text DEFAULT '' NOT NULL,
|
|
admin integer DEFAULT 0 NOT NULL,
|
|
closed integer DEFAULT 0 NOT NULL,
|
|
type text DEFAULT '' NOT NULL,
|
|
status text DEFAULT '' NOT NULL,
|
|
summary text NOT NULL,
|
|
message text DEFAULT '' NOT NULL
|
|
);
|
|
|
|
=cut
|
|
|
|
package TUWF::Bug;
|
|
|
|
use TUWF ':xml', ':html', 'html_escape';
|
|
use POSIX 'strftime';
|
|
|
|
sub new {
|
|
my $class = shift;
|
|
return bless {
|
|
table => 'issues',
|
|
types => [qw|bug feature docs other|],
|
|
default_type => 'other',
|
|
statusses => [qw|new accepted duplicate confirmed fixed wontfix worksforme|],
|
|
default_status => 'new',
|
|
admins => ['code1', 'code2'],
|
|
@_
|
|
}, $class;
|
|
}
|
|
|
|
|
|
sub dbListing {
|
|
my $self = shift;
|
|
my %o = (
|
|
results => 100,
|
|
page => 1,
|
|
closed => 2,
|
|
@_
|
|
);
|
|
$o{reverse} = 1 if !$o{sort};
|
|
|
|
my %where = (
|
|
'NOT EXISTS(SELECT 1 FROM !s im WHERE im.id > m.id AND im.issue = m.issue)' => $self->{table},
|
|
$o{id} ? ('issue = ?' => $o{id}) : (),
|
|
$o{closed} != 2 ? ('closed = ?' => $o{closed}?1:0) : (),
|
|
);
|
|
|
|
my $order = sprintf {
|
|
date => 'id %s',
|
|
}->{$o{sort}||'date'}, $o{reverse} ? 'DESC' : 'ASC';
|
|
|
|
my($r, $np) = $TUWF::OBJ->dbPage(\%o, q{
|
|
SELECT issue, summary, date, type, status, closed
|
|
FROM !s m
|
|
!W
|
|
ORDER BY !s}, $self->{table}, \%where, $order
|
|
);
|
|
return wantarray ? ($r, $np) : $r;
|
|
}
|
|
|
|
|
|
sub dbItem {
|
|
my($self, $id) = @_;
|
|
return $TUWF::OBJ->dbAll(q{
|
|
SELECT issue, summary, date, type, status, closed, name, admin, message
|
|
FROM !s
|
|
WHERE issue = ?
|
|
ORDER BY id}, $self->{table}, $id
|
|
);
|
|
}
|
|
|
|
|
|
sub dbRecent {
|
|
my $self = shift;
|
|
return $TUWF::OBJ->dbAll(q{
|
|
SELECT issue, summary, date, name
|
|
FROM !s
|
|
ORDER BY id DESC LIMIT 10}, $self->{table}
|
|
);
|
|
}
|
|
|
|
|
|
sub dbEmails {
|
|
my($self, $id) = @_;
|
|
return [ map $_->{email}, @{$TUWF::OBJ->dbAll(q|SELECT DISTINCT email FROM !s WHERE issue = ? AND email <> ''|, $self->{table}, $id)} ];
|
|
}
|
|
|
|
|
|
sub dbSave {
|
|
my($self, $id, $closed, @a) = @_;
|
|
|
|
# TODO: Issue ID allocation may currently cause two bug reports created at
|
|
# the same time to get the same id.
|
|
my $issue = $id ? '?' : '(SELECT COALESCE(MAX(issue)+1, 1) FROM !s)';
|
|
|
|
$TUWF::OBJ->dbExec(
|
|
"INSERT INTO !s (issue, date, closed, summary, name, email, type, status, message, admin) VALUES ($issue, ?, ?, !l)",
|
|
$self->{table}, $id || $self->{table}, time(), $closed?1:0, \@a);
|
|
return $TUWF::OBJ->dbRow('SELECT issue FROM !s ORDER BY date DESC LIMIT 1 ', $self->{table})->{issue};
|
|
}
|
|
|
|
|
|
# TODO: pagination / filtering
|
|
sub htmlListing {
|
|
my($s, $l, $lnk) = @_;
|
|
if(!@$l) {
|
|
p class => 'bug_nolisting', 'No bugs found! Yay?';
|
|
return;
|
|
}
|
|
table class => 'bug_listing';
|
|
thead; Tr;
|
|
td class => 'bug_col_id', 'Id';
|
|
td class => 'bug_col_type', 'Type';
|
|
td class => 'bug_col_status', 'Status';
|
|
td class => 'bug_col_date', 'Updated';
|
|
td class => 'bug_col_summary','Summary';
|
|
end; end;
|
|
for(@$l) {
|
|
Tr $_->{closed} ? (class => 'bug_closed') : ();
|
|
td class => 'bug_col_id', $_->{issue};
|
|
td class => 'bug_col_type', $_->{type};
|
|
td class => 'bug_col_status', $_->{status};
|
|
td class => 'bug_col_date', strftime '%Y-%m-%d', gmtime $_->{date};
|
|
td class => 'bug_col_summary';
|
|
a href => $lnk->($_->{issue}), $_->{summary};
|
|
end;
|
|
end;
|
|
}
|
|
end;
|
|
}
|
|
|
|
|
|
sub _escape_url {
|
|
my $str = shift;
|
|
my $r = '';
|
|
my $last = 0;
|
|
while($str =~ m{((?:https?|ftp)://[^ ><"\n\s]+[\d\w=/-])}g) {
|
|
$r .= sprintf '%s<a href="%s">%2$s</a>', html_escape(substr $str, $last, (pos($str)-length($1))-$last), html_escape($1);
|
|
$last = pos $str;
|
|
}
|
|
return $r.html_escape(substr $str, $last);
|
|
}
|
|
|
|
|
|
sub htmlItem {
|
|
my($s, $d) = @_;
|
|
my $last = $d->[$#$d];
|
|
dl class => 'bug_status';
|
|
dt 'Id'; dd $last->{issue};
|
|
dt 'Messages'; dd $#$d+1;
|
|
dt 'Type'; dd $last->{type};
|
|
dt 'Status'; dd $last->{status};
|
|
end;
|
|
div class => 'bug_item';
|
|
my $num = -1;
|
|
for my $m (@$d) {
|
|
div class => 'bug_message';
|
|
h1 !++$num ? 'Description' : "Reply $num";
|
|
dl;
|
|
dt !$num ? 'Created' : 'Added';
|
|
dd;
|
|
txt strftime '%Y-%m-%d %T GMT', gmtime $m->{date};
|
|
txt ' by ';
|
|
txt $m->{name}||'Anonymous' if !$m->{admin};
|
|
b $m->{name}||'Admin' if $m->{admin};
|
|
end;
|
|
for($num ? qw|summary type status| : ()) {
|
|
if($m->{$_} ne $d->[$num-1]{$_}) {
|
|
dt "\u$_";
|
|
dd sprintf '"%s" to "%s"', $d->[$num-1]{$_}, $m->{$_};
|
|
}
|
|
}
|
|
if($num && !$m->{closed} != !$d->[$num-1]{closed}) {
|
|
dt "Closed";
|
|
dd sprintf '"%s" to "%s"', $d->[$num-1]{closed}?'yes':'no', $m->{closed}?'yes':'no';
|
|
}
|
|
end;
|
|
p; lit _escape_url $m->{message}; end;
|
|
end;
|
|
}
|
|
end;
|
|
}
|
|
|
|
|
|
sub htmlForm {
|
|
my($s, $l, $url) = @_;
|
|
# TODO: anti-spam JS
|
|
form class => 'bug_frm', action => $url, method => 'post';
|
|
fieldset;
|
|
input type => 'hidden', name => 'bug_id', value => $l ? $l->{issue} : 0;
|
|
legend $l ? 'Reply' : 'Report a new bug';
|
|
ul;
|
|
li class => 'bug_frm_summary';
|
|
label for => 'bug_summary', 'Summary';
|
|
input type => 'text', name => 'bug_summary', id => 'bug_summary', size => 45, value => $l?$l->{summary}:'';
|
|
end;
|
|
li class => 'bug_frm_name';
|
|
label for => 'bug_name', 'Name';
|
|
input type => 'text', name => 'bug_name', id => 'bug_name', size => 20, value => $TUWF::OBJ->reqCookie('bug_name')||'';
|
|
lit ' ';
|
|
txt 'Name+email will be remembered with a cookie.';
|
|
end;
|
|
li class => 'bug_frm_mail';
|
|
label for => 'bug_email', 'Email';
|
|
input type => 'text', name => 'bug_email', id => 'bug_email', size => 20, value => $TUWF::OBJ->reqCookie('bug_email')||'';
|
|
lit ' ';
|
|
txt 'Optional, only used for notifications.';
|
|
end;
|
|
if($l) {
|
|
li class => 'bug_frm_admin';
|
|
label for => 'bug_type', 'Admin';
|
|
Select name => 'bug_type';
|
|
option value => $_, $_ eq $l->{type} ? (selected => 'selected') : (), $_ for @{$s->{types}};
|
|
end;
|
|
Select name => 'bug_status';
|
|
option value => $_, $_ eq $l->{status} ? (selected => 'selected') : (), $_ for @{$s->{statusses}};
|
|
end;
|
|
Select name => 'bug_closed';
|
|
option value => 0, !$l->{closed} ? (selected => 'selected') : (), 'Open';
|
|
option value => 1, $l->{closed} ? (selected => 'selected') : (), 'Closed';
|
|
end;
|
|
input type => 'password', name => 'bug_code', id => 'bug_code', size => 10, value => $TUWF::OBJ->reqCookie('bug_code')||'code';
|
|
end;
|
|
} else {
|
|
li class => 'bug_frm_type';
|
|
label for => 'bug_type', 'Type';
|
|
Select name => 'bug_type';
|
|
option value => $_, $_ eq $s->{default_type} ? (selected => 'selected') : (), $_ for @{$s->{types}};
|
|
end;
|
|
end;
|
|
}
|
|
li class => 'bug_frm_message';
|
|
textarea name => 'bug_message';end; br;
|
|
lit 'Please use a <a href="http://p.blicky.net/">pastebin</a> if you want to include chunks of code or program output.';
|
|
end;
|
|
li class => 'bug_frm_submit';
|
|
input type => 'submit', value => 'Submit';
|
|
end;
|
|
end 'ul';
|
|
end;
|
|
end 'form';
|
|
}
|
|
|
|
|
|
sub handleForm {
|
|
my($s, $url) = @_;
|
|
my $f = $TUWF::OBJ->formValidate(
|
|
{ post => 'bug_id', template => 'uint' },
|
|
{ post => 'bug_summary', maxlength => 200, minlength => 2 },
|
|
{ post => 'bug_name', required => 0, default => '', maxlength => 200 },
|
|
{ post => 'bug_email', required => 0, template => 'email' },
|
|
{ post => 'bug_code', required => 0, default => '' },
|
|
{ post => 'bug_message', maxlength => 256*1024, minlength => 1 },
|
|
);
|
|
return($f, undef) if $f->{_err};
|
|
return({ _err => [['bug_summary']], %$f}, undef) if $f->{bug_summary} =~ qr{http://}; # SPAM
|
|
return({ _err => [['bug_summary']], %$f}, undef) if $f->{bug_message} =~ qr{(?:<a href=|\[url=|\[link=)}i; # SPAM
|
|
|
|
$f->{bug_code} = '' if $f->{bug_code} eq 'code';
|
|
my $admin = grep($_ eq $f->{bug_code}, @{$s->{admins}}) ? 1 : 0;
|
|
|
|
my $l;
|
|
# Reply
|
|
if($f->{bug_id} > 0) {
|
|
$l = $s->dbListing(id => $f->{bug_id})->[0];
|
|
push @{$f->{_err}}, ['bug_id', 'db_check', ''] and return($f, undef) if !$l;
|
|
|
|
# Check admin things
|
|
if($admin) {
|
|
my $fa = $TUWF::OBJ->formValidate(
|
|
{ post => 'bug_type', enum => $s->{types} },
|
|
{ post => 'bug_status', enum => $s->{statusses} },
|
|
{ post => 'bug_closed', enum => [0,1] },
|
|
);
|
|
$f = { %$f, %$fa };
|
|
return($f, $l) if $f->{_err};
|
|
} else {
|
|
push @{$f->{_err}}, [ 'bug_code', 'invalid', '' ] and return($f, undef) if $f->{bug_code};
|
|
$f->{bug_type} = $l->{type};
|
|
$f->{bug_status} = $l->{status};
|
|
$f->{bug_closed} = $l->{closed};
|
|
}
|
|
|
|
# New bug
|
|
} else {
|
|
$f->{bug_status} = $s->{default_status};
|
|
$f->{bug_closed} = 0;
|
|
my $fa = $TUWF::OBJ->formValidate({ post => 'bug_type', enum => $s->{types} });
|
|
$f = { %$f, %$fa };
|
|
return($f, $l) if $f->{_err};
|
|
}
|
|
|
|
# No errors? Save!
|
|
my $id = $s->dbSave(map($f->{"bug_$_"}, qw|id closed summary name email type status message|), $admin);
|
|
|
|
my $u = $url->($id);
|
|
|
|
# For replies, send out notification emails
|
|
if($l) {
|
|
my $mails = $s->dbEmails($id);
|
|
my $base = $TUWF::OBJ->reqBaseURI();
|
|
for(grep $_ ne $f->{bug_email}, @$mails) {
|
|
$TUWF::OBJ->mail(
|
|
"Hello!\n\n".
|
|
"A new reply has been posted to a bug you have previously shown\n".
|
|
"an interest in. You can find the reply at the following URL:\n\n".
|
|
" $base$u\n\n".
|
|
"If you do not wish to receive any more notifications for this (and\n".
|
|
"perhaps other) bugs, please reply to this email stating your intent.",
|
|
Subject => "Reply to $f->{bug_summary}",
|
|
To => $_,
|
|
);
|
|
}
|
|
}
|
|
|
|
$l = $s->dbListing(id => $id)->[0] if !$l;
|
|
$TUWF::OBJ->resRedirect($u, 'post');
|
|
$f->{$_} and $TUWF::OBJ->resCookie($_ => $f->{$_}, expires => time()+365*24*3600) for ('bug_name', 'bug_email', 'bug_code');
|
|
|
|
return($f, $l);
|
|
}
|
|
|
|
|
|
sub atomFeed {
|
|
my($s, $lnk) = @_;
|
|
|
|
my $r = $s->dbRecent();
|
|
my $t = $r->[0]{date}||1463296545;
|
|
|
|
$TUWF::OBJ->resHeader('Last-Modified' => strftime '%a, %d %b %Y %H:%M:%S GMT', gmtime $t);
|
|
$TUWF::OBJ->resHeader('Content-Type' => 'application/atom+xml');
|
|
xml;
|
|
tag feed => xmlns => 'http://www.w3.org/2005/Atom', 'xml:lang' => 'en', 'xml:base' => 'https://dev.yorhel.nl/';
|
|
tag title => "\u$s->{table} Recent Comments";
|
|
tag updated => strftime('%Y-%m-%dT%H:%M:%SZ', gmtime $t);
|
|
tag id => $lnk->('feed.atom');
|
|
tag link => rel => 'self', type => 'application/atom+xml', href => $lnk->('feed.atom'), undef;
|
|
tag link => rel => 'alternate', type => 'text/html', href => $lnk->(''), undef;
|
|
|
|
for(@$r) {
|
|
my $d = strftime('%Y-%m-%dT%H:%M:%SZ', gmtime $_->{date});
|
|
tag 'entry';
|
|
tag id => $lnk->($_->{issue})."#$d";
|
|
tag title => $_->{summary};
|
|
tag updated => $d;
|
|
tag published => $d;
|
|
tag 'author';
|
|
tag name => $_->{name};
|
|
end;
|
|
tag link => rel => 'alternate', type => 'text/html', href => $lnk->($_->{issue}), undef;
|
|
end 'entry';
|
|
}
|
|
end 'feed';
|
|
}
|
|
|
|
1;
|