diff options
Diffstat (limited to 'rt/bin')
| -rwxr-xr-x | rt/bin/mason_handler.fcgi | 68 | ||||
| -rw-r--r-- | rt/bin/mason_handler.fcgi.in | 68 | ||||
| -rwxr-xr-x | rt/bin/mason_handler.scgi | 43 | ||||
| -rw-r--r-- | rt/bin/mason_handler.scgi.in | 43 | ||||
| -rw-r--r-- | rt/bin/mason_handler.svc | 234 | ||||
| -rw-r--r-- | rt/bin/mason_handler.svc.in | 234 | ||||
| -rw-r--r-- | rt/bin/rt-commit-handler | 846 | ||||
| -rw-r--r-- | rt/bin/rt-commit-handler.in | 846 | ||||
| -rw-r--r-- | rt/bin/rt-crontool | 220 | ||||
| -rw-r--r-- | rt/bin/rt-crontool.in | 220 | ||||
| -rwxr-xr-x | rt/bin/rt-mailgate | 648 | ||||
| -rw-r--r-- | rt/bin/rt-mailgate.in | 648 | ||||
| -rw-r--r-- | rt/bin/rt.in | 1816 | ||||
| -rwxr-xr-x | rt/bin/webmux.pl | 148 | ||||
| -rw-r--r-- | rt/bin/webmux.pl.in | 148 |
15 files changed, 6230 insertions, 0 deletions
diff --git a/rt/bin/mason_handler.fcgi b/rt/bin/mason_handler.fcgi new file mode 100755 index 000000000..93d1f8855 --- /dev/null +++ b/rt/bin/mason_handler.fcgi @@ -0,0 +1,68 @@ +#!/usr/bin/perl +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +use File::Basename; +require ('/opt/rt3/bin/webmux.pl'); + +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +# Enter CGI::Fast mode, which should also work as a vanilla CGI script. +require CGI::Fast; + +RT::Init(); + +# Response loop +while ( my $cgi = CGI::Fast->new ) { + # the whole point of fastcgi requires the env to get reset here.. + # So we must squash it again + $ENV{'PATH'} = '/bin:/usr/bin'; + $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'}; + $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; + $ENV{'ENV'} = '' if defined $ENV{'ENV'}; + $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + + RT::ConnectToDatabase(); + + if ( ( !$h->interp->comp_exists( $cgi->path_info ) ) + && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) { + $cgi->path_info( $cgi->path_info . "/index.html" ); + } + + eval { $h->handle_cgi_object($cgi); }; + if ($@) { + $RT::Logger->crit($@); + } + + + if ($RT::Handle->TransactionDepth) { + $RT::Handle->ForceRollback; + $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") ; + } + + +} + +1; diff --git a/rt/bin/mason_handler.fcgi.in b/rt/bin/mason_handler.fcgi.in new file mode 100644 index 000000000..a009663b9 --- /dev/null +++ b/rt/bin/mason_handler.fcgi.in @@ -0,0 +1,68 @@ +#!@PERL@ +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +use File::Basename; +require ('@RT_BIN_PATH@/webmux.pl'); + +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +# Enter CGI::Fast mode, which should also work as a vanilla CGI script. +require CGI::Fast; + +RT::Init(); + +# Response loop +while ( my $cgi = CGI::Fast->new ) { + # the whole point of fastcgi requires the env to get reset here.. + # So we must squash it again + $ENV{'PATH'} = '/bin:/usr/bin'; + $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'}; + $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; + $ENV{'ENV'} = '' if defined $ENV{'ENV'}; + $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + + RT::ConnectToDatabase(); + + if ( ( !$h->interp->comp_exists( $cgi->path_info ) ) + && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) { + $cgi->path_info( $cgi->path_info . "/index.html" ); + } + + eval { $h->handle_cgi_object($cgi); }; + if ($@) { + $RT::Logger->crit($@); + } + + + if ($RT::Handle->TransactionDepth) { + $RT::Handle->ForceRollback; + $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") ; + } + + +} + +1; diff --git a/rt/bin/mason_handler.scgi b/rt/bin/mason_handler.scgi new file mode 100755 index 000000000..7774189ee --- /dev/null +++ b/rt/bin/mason_handler.scgi @@ -0,0 +1,43 @@ +#!/usr/local/bin/speedy +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +require ('/opt/rt3/bin/webmux.pl'); + +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +require CGI; + +RT::Init(); + +my $cgi = CGI->new; +if ( ( !$h->interp->comp_exists( $cgi->path_info ) ) + && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) { + $cgi->path_info( $cgi->path_info . "/index.html" ); +} + +$h->handle_cgi_object($cgi); + +1; diff --git a/rt/bin/mason_handler.scgi.in b/rt/bin/mason_handler.scgi.in new file mode 100644 index 000000000..614d4d47a --- /dev/null +++ b/rt/bin/mason_handler.scgi.in @@ -0,0 +1,43 @@ +#!@SPEEDY_BIN@ +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +require ('@RT_BIN_PATH@/webmux.pl'); + +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +require CGI; + +RT::Init(); + +my $cgi = CGI->new; +if ( ( !$h->interp->comp_exists( $cgi->path_info ) ) + && ( $h->interp->comp_exists( $cgi->path_info . "/index.html" ) ) ) { + $cgi->path_info( $cgi->path_info . "/index.html" ); +} + +$h->handle_cgi_object($cgi); + +1; diff --git a/rt/bin/mason_handler.svc b/rt/bin/mason_handler.svc new file mode 100644 index 000000000..c05d21e69 --- /dev/null +++ b/rt/bin/mason_handler.svc @@ -0,0 +1,234 @@ +#!/usr/bin/perl +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +=head1 NAME + +mason_handler.svc - Win32 IIS Service handler for RT + +=head1 SYNOPSIS + + perl mason_handler.svc --install # install as service + perl mason_handler.svc --deinstall # deinstall this service + perl mason_handler.svc --help # show this help + perl mason_handler.svc # launch handler from command line + +=head1 DESCRIPTION + +This script manages a stand-alone FastCGI server, and populates the necessary +registry settings to run it with Microsoft IIS Server 4.0 or above. + +Before running it, you need to install the B<FCGI> module from CPAN, as well as +B<Win32::Daemon> from L<http://www.roth.net/perl/Daemon/> if you want to install +itself as a service. + +This script will automatically create a virtual directory under the IIS root; +its name is taken from C<$WebPath> in the F<RT_Config.pm> file. Additionally, +please install the ISAPI binary from L<http://www.caraveo.com/fastcgi/> and set +up an ISAPI Script Map that maps F<.html> files to F<isapi_fcgi.dll>. + +Once the service is launched (either via C<net start RTFastCGI> or by running +C<perl mason_handler.svc>), a FCGI server will start and bind to port C<8284> +(mnemonics: the ASCII value of C<R> and C<T>); the ISAPI handler's C<BindPath> +registry setting will also be automatically populated. + +=cut + +use strict; +use File::Basename; +require (dirname(__FILE__) . '/webmux.pl'); + +use Cwd; +use File::Spec; + +use Win32; +use Win32::Process; +use Win32::Service; +use Win32::TieRegistry; + +my $ProcessObj; + +BEGIN { + my $runsvc = sub { + Win32::Process::Create( + $ProcessObj, $^X, "$^X $0 --run", 0, NORMAL_PRIORITY_CLASS, "." + ) or do { + die Win32::FormatMessage( Win32::GetLastError() ); + }; + + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + $path =~ s|bin$|share\\html|; + + $Win32::TieRegistry::Registry->{ + 'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\\'. + 'W3SVC\Parameters\Virtual Roots\\' + }->{$RT::WebPath || '/'} = "$path,,205"; + + $Win32::TieRegistry::Registry->{ + 'HKEY_LOCAL_MACHINE\Software\FASTCGI\.html\\' + }->{'BindPath'} = $ENV{'FCGI_SOCKET_PATH'}; + + Win32::Service::StartService(Win32::NodeName, 'W3SVC'); + }; + + if ($ARGV[0] eq '--deinstall') { + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + + require Win32::Daemon; + Win32::Daemon::DeleteService('RTFastCGI'); + warn "Service 'RTFastCGI' successfully deleted.\n"; + exit; + } + elsif ($ARGV[0] eq '--install') { + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + + require Win32::Daemon; + Win32::Daemon::DeleteService('RTFastCGI'); + + my $rv = Win32::Daemon::CreateService( { + machine => '', + name => 'RTFastCGI', + display => 'RT FastCGI Handler', + path => $^X, + user => '', + pwd => $path, + description => 'Enables port 8284 as the RT FastCGI handler.', + parameters => File::Spec->catfile( + $path, File::Basename::basename($0) + ) . ' --service', + } ); + + if ($rv) { + warn "Service 'RTFastCGI' successfully created.\n"; + } + else { + warn "Failed to add service: " . Win32::FormatMessage( + Win32::Daemon::GetLastError() + ) . "\n"; + } + exit; + } + elsif ($ARGV[0] eq '--service') { + require Win32::Daemon; + + my $PrevState = Win32::Daemon::SERVICE_START_PENDING(); + Win32::Daemon::StartService() or die $^E; + + while ( 1 ) { + my $State = Win32::Daemon::State(); + last if $State == Win32::Daemon::SERVICE_STOPPED(); + + if ( $State == Win32::Daemon::SERVICE_START_PENDING() ) { + $runsvc->(); + Win32::Daemon::State( Win32::Daemon::SERVICE_RUNNING() ); + $PrevState = Win32::Daemon::SERVICE_RUNNING(); + } + elsif ( $State == Win32::Daemon::SERVICE_CONTINUE_PENDING() ) { + $ProcessObj->Resume; + Win32::Daemon::State( Win32::Daemon::SERVICE_RUNNING() ); + $PrevState = Win32::Daemon::SERVICE_RUNNING(); + } + elsif ( $State == Win32::Daemon::SERVICE_STOP_PENDING() ) { + $ProcessObj->Kill(0); + Win32::Daemon::State( Win32::Daemon::SERVICE_STOPPED() ); + $PrevState = Win32::Daemon::SERVICE_STOPPED(); + } + elsif ( $State == Win32::Daemon::SERVICE_RUNNING() ) { + my $Message = Win32::Daemon::QueryLastMessage(1); + if ( $Message == Win32::Daemon::SERVICE_CONTROL_INTERROGATE() ) { + Win32::Daemon::State( $PrevState ); + } + elsif ( $Message == Win32::Daemon::SERVICE_CONTROL_SHUTDOWN() ) { + Win32::Daemon::State( Win32::Daemon::SERVICE_STOP_PENDING(), 15000 ); + } + elsif ( $Message != Win32::Daemon::SERVICE_CONTROL_NONE() ) { + Win32::Daemon::State( $PrevState ); + } + } + + Win32::Sleep( 1000 ); + } + + Win32::Daemon::StopService(); + exit; + } + elsif ($ARGV[0] eq '--help') { + system("perldoc $0"); + exit; + } + elsif ($ARGV[0] ne '--run') { + $SIG{__DIE__} = sub { $ProcessObj->Kill(0) if $ProcessObj }; + $runsvc->(); + warn "RT FastCGI Handler launched. Press [Enter] to terminate...\n"; + <STDIN>; + exit; + } +} + +############################################################################### + +warn "Begin listening on $ENV{'FCGI_SOCKET_PATH'}\n"; + +require CGI::Fast; +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +RT::Init(); + +# Response loop +while( my $cgi = CGI::Fast->new ) { + my $comp = $ENV{'PATH_INFO'}; + + $comp = $1 if ($comp =~ /^(.*)$/); + $comp =~ s|^$RT::WebPath\b||i; + $comp .= "index.html" if ($comp =~ /\/$/); + $comp =~ s/.pl$/.html/g; + + warn "Serving $comp\n"; + + $h->handle_cgi($comp); + # _should_ always be tied +} + +1; + +=head1 AUTHORS + +Autrijus Tang E<lt>autrijus@autrijus.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2002 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/rt/bin/mason_handler.svc.in b/rt/bin/mason_handler.svc.in new file mode 100644 index 000000000..0ba1f51b5 --- /dev/null +++ b/rt/bin/mason_handler.svc.in @@ -0,0 +1,234 @@ +#!@PERL@ +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +=head1 NAME + +mason_handler.svc - Win32 IIS Service handler for RT + +=head1 SYNOPSIS + + perl mason_handler.svc --install # install as service + perl mason_handler.svc --deinstall # deinstall this service + perl mason_handler.svc --help # show this help + perl mason_handler.svc # launch handler from command line + +=head1 DESCRIPTION + +This script manages a stand-alone FastCGI server, and populates the necessary +registry settings to run it with Microsoft IIS Server 4.0 or above. + +Before running it, you need to install the B<FCGI> module from CPAN, as well as +B<Win32::Daemon> from L<http://www.roth.net/perl/Daemon/> if you want to install +itself as a service. + +This script will automatically create a virtual directory under the IIS root; +its name is taken from C<$WebPath> in the F<RT_Config.pm> file. Additionally, +please install the ISAPI binary from L<http://www.caraveo.com/fastcgi/> and set +up an ISAPI Script Map that maps F<.html> files to F<isapi_fcgi.dll>. + +Once the service is launched (either via C<net start RTFastCGI> or by running +C<perl mason_handler.svc>), a FCGI server will start and bind to port C<8284> +(mnemonics: the ASCII value of C<R> and C<T>); the ISAPI handler's C<BindPath> +registry setting will also be automatically populated. + +=cut + +use strict; +use File::Basename; +require (dirname(__FILE__) . '/webmux.pl'); + +use Cwd; +use File::Spec; + +use Win32; +use Win32::Process; +use Win32::Service; +use Win32::TieRegistry; + +my $ProcessObj; + +BEGIN { + my $runsvc = sub { + Win32::Process::Create( + $ProcessObj, $^X, "$^X $0 --run", 0, NORMAL_PRIORITY_CLASS, "." + ) or do { + die Win32::FormatMessage( Win32::GetLastError() ); + }; + + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + $path =~ s|bin$|share\\html|; + + $Win32::TieRegistry::Registry->{ + 'HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\\'. + 'W3SVC\Parameters\Virtual Roots\\' + }->{$RT::WebPath || '/'} = "$path,,205"; + + $Win32::TieRegistry::Registry->{ + 'HKEY_LOCAL_MACHINE\Software\FASTCGI\.html\\' + }->{'BindPath'} = $ENV{'FCGI_SOCKET_PATH'}; + + Win32::Service::StartService(Win32::NodeName, 'W3SVC'); + }; + + if ($ARGV[0] eq '--deinstall') { + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + + require Win32::Daemon; + Win32::Daemon::DeleteService('RTFastCGI'); + warn "Service 'RTFastCGI' successfully deleted.\n"; + exit; + } + elsif ($ARGV[0] eq '--install') { + chdir File::Basename::dirname($0); + my $path = Cwd::cwd(); + $path =~ s|/|\\|g; + + require Win32::Daemon; + Win32::Daemon::DeleteService('RTFastCGI'); + + my $rv = Win32::Daemon::CreateService( { + machine => '', + name => 'RTFastCGI', + display => 'RT FastCGI Handler', + path => $^X, + user => '', + pwd => $path, + description => 'Enables port 8284 as the RT FastCGI handler.', + parameters => File::Spec->catfile( + $path, File::Basename::basename($0) + ) . ' --service', + } ); + + if ($rv) { + warn "Service 'RTFastCGI' successfully created.\n"; + } + else { + warn "Failed to add service: " . Win32::FormatMessage( + Win32::Daemon::GetLastError() + ) . "\n"; + } + exit; + } + elsif ($ARGV[0] eq '--service') { + require Win32::Daemon; + + my $PrevState = Win32::Daemon::SERVICE_START_PENDING(); + Win32::Daemon::StartService() or die $^E; + + while ( 1 ) { + my $State = Win32::Daemon::State(); + last if $State == Win32::Daemon::SERVICE_STOPPED(); + + if ( $State == Win32::Daemon::SERVICE_START_PENDING() ) { + $runsvc->(); + Win32::Daemon::State( Win32::Daemon::SERVICE_RUNNING() ); + $PrevState = Win32::Daemon::SERVICE_RUNNING(); + } + elsif ( $State == Win32::Daemon::SERVICE_CONTINUE_PENDING() ) { + $ProcessObj->Resume; + Win32::Daemon::State( Win32::Daemon::SERVICE_RUNNING() ); + $PrevState = Win32::Daemon::SERVICE_RUNNING(); + } + elsif ( $State == Win32::Daemon::SERVICE_STOP_PENDING() ) { + $ProcessObj->Kill(0); + Win32::Daemon::State( Win32::Daemon::SERVICE_STOPPED() ); + $PrevState = Win32::Daemon::SERVICE_STOPPED(); + } + elsif ( $State == Win32::Daemon::SERVICE_RUNNING() ) { + my $Message = Win32::Daemon::QueryLastMessage(1); + if ( $Message == Win32::Daemon::SERVICE_CONTROL_INTERROGATE() ) { + Win32::Daemon::State( $PrevState ); + } + elsif ( $Message == Win32::Daemon::SERVICE_CONTROL_SHUTDOWN() ) { + Win32::Daemon::State( Win32::Daemon::SERVICE_STOP_PENDING(), 15000 ); + } + elsif ( $Message != Win32::Daemon::SERVICE_CONTROL_NONE() ) { + Win32::Daemon::State( $PrevState ); + } + } + + Win32::Sleep( 1000 ); + } + + Win32::Daemon::StopService(); + exit; + } + elsif ($ARGV[0] eq '--help') { + system("perldoc $0"); + exit; + } + elsif ($ARGV[0] ne '--run') { + $SIG{__DIE__} = sub { $ProcessObj->Kill(0) if $ProcessObj }; + $runsvc->(); + warn "RT FastCGI Handler launched. Press [Enter] to terminate...\n"; + <STDIN>; + exit; + } +} + +############################################################################### + +warn "Begin listening on $ENV{'FCGI_SOCKET_PATH'}\n"; + +require CGI::Fast; +my $h = &RT::Interface::Web::NewCGIHandler(@RT::MasonParameters); + +RT::Init(); + +# Response loop +while( my $cgi = CGI::Fast->new ) { + my $comp = $ENV{'PATH_INFO'}; + + $comp = $1 if ($comp =~ /^(.*)$/); + $comp =~ s|^$RT::WebPath\b||i; + $comp .= "index.html" if ($comp =~ /\/$/); + $comp =~ s/.pl$/.html/g; + + warn "Serving $comp\n"; + + $h->handle_cgi($comp); + # _should_ always be tied +} + +1; + +=head1 AUTHORS + +Autrijus Tang E<lt>autrijus@autrijus.orgE<gt> + +=head1 COPYRIGHT + +Copyright 2002 by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See L<http://www.perl.com/perl/misc/Artistic.html> + +=cut diff --git a/rt/bin/rt-commit-handler b/rt/bin/rt-commit-handler new file mode 100644 index 000000000..29e443ebd --- /dev/null +++ b/rt/bin/rt-commit-handler @@ -0,0 +1,846 @@ +#!/usr/bin/perl -w +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +# {{{ Docs +# -*-Perl-*- +# +#ident "@(#)ccvs/contrib:$Name: $:$Id: rt-commit-handler,v 1.1 2003-07-15 13:16:15 ivan Exp $" +# +# Perl filter to handle the log messages from the checkin of files in multiple +# directories. This script will group the lists of files by log message, and +# send one piece of mail per unique message, no matter how many files are +# committed. + +=head1 NAME rt-commit-handler + +=head1 USAGE + + + +=head2 Regular use + +Stick the following in in CVSROOT/commitinfo + + ALL /opt/rt3/bin/rt-commit-handler --record-last-dir + +Stick the following in CVSROOT/loginfo + + ALL /opt/rt3/bin/rt-commit-handler --cvs-root /pathtocvs/root --rt %{Vvts} + +=head2 Invocation (advanced use) + +rt-commit-handler --cvs-root /path/to/cvs/root [-d] [-D] [-r] [-M module] \ + [[-m mailto] ...] [[-R replyto] ...] [-f logfile] + + + -d - turn on debugging + -m mailto - send mail to "mailto" (multiple) + -R replyto - set the "Reply-To:" to "replyto" (multiple) + -M modulename - set module name to "modulename" + -f logfile - write commit messages to logfile too + -D - generate diff commands + --rt - invoke RT commit handler + --cvs-root - specify your CVS root + + --record-last-dir - Record the last directory with changes in + pre-commit (commitinfo) mode + + +=cut + +# }}} + +use strict; +use Carp; +use Getopt::Long; +use Text::Wrap; +use Digest::MD5; +use MIME::Entity; + +use lib ("/opt/rt3/lib", "/opt/rt3/local/lib"); + +use RT::Interface::CLI qw(CleanEnv GetCurrentUser GetMessageContent loc); + +use vars + qw(@MAILER $TMPDIR $FILE_PREFIX $LASTDIR_FILE $HASH_FILE $VERSION_FILE $MESSAGE_FILE $MAIL_FILE $DEBUG $MAILTO $REPLYTO $id $MODULE_NAME + $LOGIN $COMMITLOG $CVS_ROOT $RT_HANDLER); + +#Clean out all the nasties from the environment +CleanEnv(); + +#Load etc/config.pm and drop privs +RT::LoadConfig(); + +#Drop setgid permissions +RT::DropSetGIDPermissions(); + +# {{{ Variable setup +$TMPDIR = '/tmp'; +$FILE_PREFIX = $TMPDIR . '/#cvs.'; + +# The root of your CVS install. we should get this from some smarter place. +# It needs a trailing / + +$LASTDIR_FILE = $FILE_PREFIX . "lastdir"; +$HASH_FILE = $FILE_PREFIX . "hash"; +$VERSION_FILE = $FILE_PREFIX . "version"; +$MESSAGE_FILE = $FILE_PREFIX . "message"; +$MAIL_FILE = $FILE_PREFIX . "mail"; + +$DEBUG = 0; +$RT_HANDLER = 1; + +$MAILTO = ''; + +my @files = (); +my (@log_lines); +my $do_diff = 0; +my $id = getpgrp(); # note, you *must* use a shell which does setpgrp() +$LOGIN = getpwuid($<); + +# }}} + +die "User could not be found" unless ($LOGIN); + +# {{{ parse command line arguments (file list is seen as one arg) +# +while ( my $arg = shift @ARGV ) { + + if ( $arg eq '-d' ) { + $DEBUG = 1; + warn "Debug turned on...\n"; + } + elsif ( $arg =~ /^--record-last-dir$/i ) { + record_last_dir( $id, $ARGV[0] ); + exit(0); + } + elsif ( $arg eq '-m' ) { + $MAILTO .= ", " if $MAILTO; + $MAILTO .= shift @ARGV; + } + elsif ( $arg eq '--rt' ) { + $RT_HANDLER = 1; + } + elsif ( $arg eq '-R' ) { + $REPLYTO .= ", " if $REPLYTO; + $REPLYTO .= shift @ARGV; + } + elsif ( $arg eq '-M' ) { + die ("too many '-M' args\n") if $MODULE_NAME; + $MODULE_NAME = shift @ARGV; + } + elsif ( $arg eq '--cvs-root' ) { + $CVS_ROOT = shift @ARGV; + $CVS_ROOT .= "/" unless ( $CVS_ROOT =~ /\/$/ ); + } + elsif ( $arg eq '-f' ) { + die ("too many '-f' args\n") if $COMMITLOG; + $COMMITLOG = shift @ARGV; + + # This is a disgusting hack to untaint $COMMITLOG if we're running from + # setgid cvs. + $COMMITLOG = untaint($COMMITLOG); + } + elsif ( $arg eq '-D' ) { + $do_diff = 1; + } + else { + @files = split ( ' ', $arg ); + last; + } +} + +# }}} + +$REPLYTO = $LOGIN unless ($REPLYTO); + +# for now, the first "file" is the repository directory being committed, +# relative to the $CVSROOT location +# +my $dir = shift @files; + +# XXX there are some ugly assumptions in here about module names and +# XXX directories relative to the $CVSROOT location -- really should +# XXX read $CVSROOT/CVSROOT/modules, but that's not so easy to do, since +# XXX we have to parse it backwards. +# +# XXX For now we set the `module' name to the top-level directory name. +# +unless ($MODULE_NAME) { + ($MODULE_NAME) = split ( '/', $dir, 2 ); +} + +if ($DEBUG) { + warn "module - ", $MODULE_NAME, "\n"; + warn "dir - ", $dir, "\n"; + warn "files - ", join ( " ", @files ), "\n"; + warn "id - ", $id, "\n"; +} + +# {{{ Check for a new directory or an import command. + +# +# files[0] - "-" +# files[1] - "New" +# files[2] - "directory" +# +# files[0] - "-" +# files[1] - "Imported" +# files[2] - "sources" +# +if ( $files[0] eq "-" ) { + + #we just don't care about New Directory notes + unless ( $files[1] eq "New" && $files[2] eq "directory" ) { + + my @text = (); + + push @text, build_header(); + push @text, ""; + + while ( my $line = <STDIN> ) { + chop $line; # Drop the newline + push @text, $line; + } + + append_logfile( $COMMITLOG, @text ) if ($COMMITLOG); + + mail_notification( $id, @text ); + } + + exit 0; +} + +# }}} + +# {{{ Collect just the log message from stdin. +# + +while ( my $line = <STDIN> ) { + chop $line; # strip the newline + last if ( $line =~ /^Log Message:$/ ); +} +while ( my $line = <STDIN> ) { + chop $line; # strip the newline + $line =~ s/\s+$//; # strip trailing white space + push @log_lines, $line; +} + +my $md5 = Digest::MD5->new(); +foreach my $line (@log_lines) { + $md5->add( $line . "\n" ); +} +my $hash = $md5->hexdigest(); + +warn "hash = $hash\n" if ($DEBUG); + +if ( !-e "$MESSAGE_FILE.$id.$hash" ) { + append_logfile( "$HASH_FILE.$id", $hash ); + write_file( "$MESSAGE_FILE.$id.$hash", @log_lines ); +} + +# }}} + +# Spit out the information gathered in this pass. + +append_logfile( "$VERSION_FILE.$id.$hash", $dir . '/', @files ); + +# {{{ Check whether this is the last directory. If not, quit. + +warn "Checking current dir against last dir $LASTDIR_FILE.$id\n" if ($DEBUG); + +my @last_dir = read_file("$LASTDIR_FILE.$id"); + +unless ($CVS_ROOT) { + die "No cvs root specified with --cvs-root. Can't continue."; +} + +if ( $last_dir[0] ne $CVS_ROOT . $dir ) { + warn "Current directory $CVS_ROOT$dir is not last directory $last_dir[0].\n" + if ($DEBUG); + exit 0; +} + +# }}} + +# {{{ End Of Commits! +# + +# This is it. The commits are all finished. Lump everything together +# into a single message, fire a copy off to the mailing list, and drop +# it on the end of the Changes file. +# + +# +# Produce the final compilation of the log messages +# + +my @hashes = read_file("$HASH_FILE.$id"); +my (@text); + +push @text, build_header(); +push @text, ""; + +my ( @added_files, @modified_files, @removed_files ); + +foreach my $hash (@hashes) { + + # In case we're running setgid, make sure the hash file hasn't been hacked. + $hash =~ m/([a-z0-9]*)/ || die "*** Hacking attempt detected\n"; + $hash = $1; + + my @files = read_file("$VERSION_FILE.$id.$hash"); + my @log_lines = read_file("$MESSAGE_FILE.$id.$hash"); + + my $working_on_dir; # gets set as we iterate through the files. + foreach my $file (@files) { + + #If we've entered a new directory, make a note of that and remove the trailing / + + if ( $file =~ s'\/$'' ) { + $working_on_dir = $file; + next; + } + + my @file_entry = ( split ( ',', $file, 4 ), $working_on_dir ); + + # file_entry looks like ths: + + # 0 1 2 3 4 + # Old rev : new rev : tag: file :directory + my $entry = {}; + $entry->{'old'} = $file_entry[0]; + $entry->{'new'} = $file_entry[1]; + $entry->{'tag'} = $file_entry[2]; + $entry->{'file'} = $file_entry[3]; + $entry->{'dir'} = $file_entry[4]; + + if ( $file_entry[0] eq 'NONE' ) { + $entry->{'old'} = '0'; + push @added_files, $entry; + } + elsif ( $file_entry[1] eq 'NONE' ) { + $entry->{'new'} = '0'; + push @removed_files, $entry; + } + else { + push @modified_files, $entry; + } + } +} + +# }}} + +# {{{ start building up the body + +# Strip leading and trailing blank lines from the log message. Also +# compress multiple blank lines in the body of the message down to a +# single blank line. +# + +my $blank = 1; +@log_lines = map { + my $wasblank = $blank; + $blank = $_ eq ''; + $blank && $wasblank ? () : $_; +} @log_lines; + +pop @log_lines if $blank; + +@modified_files = order_and_summarize_diffs(@modified_files); +@added_files = order_and_summarize_diffs(@added_files); +@removed_files = order_and_summarize_diffs(@removed_files); + +push @text, "Modified Files:", format_lists(@modified_files) + if (@modified_files); + +push @text, "Added Files:", format_lists(@added_files) if (@added_files); + +push @text, "Removed Files:", format_lists(@removed_files) if (@removed_files); + +push @text, "", "Log Message", @log_lines if (@log_lines); + +push @text, ""; + +if ($RT_HANDLER) { + rt_handler( + @log_lines, "\n", + loc("To generate a diff of this commit:\n"), "\n", + format_diffs( @modified_files, @added_files, @removed_files ) + ); +} + +if ($COMMITLOG) { + append_logfile( $COMMITLOG, @text ); +} + +if ($do_diff) { + push @text, ""; + push @text, loc("To generate a diff of this commit:"); + push @text, format_diffs( @modified_files, @added_files, @removed_files ); + push @text, ""; +} + +# }}} + +# {{{ Mail out the notification. + +mail_notification( $id, @text ); + +# }}} + +# {{{ clean up + +unless ($DEBUG) { + $hash = untaint($hash); + $id = untaint($id); + unlink "$VERSION_FILE.$id.$hash"; + unlink "$MESSAGE_FILE.$id.$hash"; + unlink "$MAIL_FILE.$id"; + unlink "$LASTDIR_FILE.$id"; + unlink "$HASH_FILE.$id"; +} + +# }}} + +exit 0; + +# {{{ Subroutines +# + +# {{{ append_logfile +sub append_logfile { + my $filename = shift; + my (@lines) = @_; + + $filename = untaint($filename); + + open( FILE, ">>$filename" ) + || die ("Cannot open file $filename for append.\n"); + foreach my $line (@lines) { + print FILE $line . "\n"; + } + close(FILE); +} + +# }}} + +# {{{ write_file +sub write_file { + my $filename = shift; + my (@lines) = @_; + + $filename = untaint($filename); + + open( FILE, ">$filename" ) + || die ("Cannot open file $filename for write.\n"); + foreach my $line (@lines) { + print FILE $line . "\n"; + } + close(FILE); +} + +# }}} + +# {{{ read_file +sub read_file { + my $filename = shift; + my (@lines); + + open( FILE, "<$filename" ) + || die ("Cannot open file $filename for read.\n"); + while ( my $line = <FILE> ) { + chop $line; + push @lines, $line; + } + close(FILE); + + return (@lines); +} + +# }}} + +# {{{ sub format_lists + +sub format_lists { + my @items = (@_); + + my $files = ""; + map { + $_->{'files'} && ( $files .= ' ' . join ( ' ', @{ $_->{'files'} } ) ); + } @items; + + my @lines = wrap( "\t", "\t\t", $files ); + return (@lines); + +} + +# }}} + +# {{{ sub format_diffs + +sub format_diffs { + my @items = (@_); + + my @lines; + foreach my $item (@items) { + next unless ( $item->{'files'} ); + push ( @lines, + "cvs diff -r" + . $item->{'old'} . " -r" + . $item->{'new'} . " " + . join ( " ", @{ $item->{'files'} } ) . "\n" ); + + } + + @lines = fill( "\t", "\t\t", @lines ); + + return (@lines); +} + +# }}} + +# {{{ sub order_and_summarize_diffs { + +# takes an array of file items +# returns a sorted array of fileset items, which are like file items, except they can have an array of files, rather than +# a singleton file. + +sub order_and_summarize_diffs { + + my @files = (@_); + + # Sort by tag, dir, file. + @files = sort { + $a->{'tag'} cmp $b->{'tag'} + || $a->{'dir'} cmp $b->{'dir'} + || $a->{'file'} cmp $b->{'file'}; + } @files; + + # Combine adjacent rows that are the same modulo the file name. + + my @items = (undef); + + foreach my $file (@files) { + if ( $#items == -1 #if it's empty + || ( !defined $items[-1]->{'old'} + || $items[-1]->{'old'} ne $file->{'old'} ) + || ( !defined $items[-1]->{'new'} + || $items[-1]->{'new'} ne $file->{'new'} ) + || ( !defined $items[-1]->{'tag'} + || $items[-1]->{'tag'} ne $file->{'tag'} ) ) + { + + push ( @items, $file ); + } + push ( @{ $items[-1]->{'files'} }, + $file->{'dir'} . "/" . $file->{'file'} ); + } + + return (@items); +} + +# }}} + +# {{{ build_header + +sub build_header { + my $now = gmtime; + my $header = + sprintf( "Module Name:\t%s\nCommitted By:\t%s\nDate:\t\t%s %s %s", + $MODULE_NAME, $LOGIN, substr( $now, 0, 19 ), "UTC", + substr( $now, 20, 4 ) ); + return ($header); +} + +# }}} + +# {{{ mail_notification +sub mail_notification { + my $id = shift; + my (@text) = @_; + write_file( "$MAIL_FILE.$id", "From: " . $LOGIN, + "Subject: CVS commit: " . $MODULE_NAME, "To: " . $MAILTO, + "Reply-To: " . $REPLYTO, "", "", @text ); + + my $entity = MIME::Entity->build( + From => $LOGIN, + To => $MAILTO, + Subject => "CVS commit: " . $MODULE_NAME, + 'Reply-To' => $REPLYTO, + Data => join ( "\n", @text ) + ); + if ( $RT::MailCommand eq 'sendmailpipe' ) { + open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) + || die "Couldn't send mail: " . $@ . "\n"; + print MAIL $entity->as_string; + close(MAIL); + } + else { + $entity->send( $RT::MailCommand, $RT::MailParams ); + } + +} + +# }}} + +# {{{ sub record_last_dir + +sub record_last_dir { + my $id = shift; + my $dir = shift; + + # make a note of this directory. later, we'll use this to + # figure out if we've gone through the whole commit, + # for something that is a bad mockery of attomic commits. + + warn "about to write $dir to $LASTDIR_FILE.$id" if ($DEBUG); + + write_file( "$LASTDIR_FILE.$id", $dir ); +} + +# }}} + +# {{{ Get the RT stuff set up + +# {{{ sub rt_handler + +sub rt_handler { + my (@LogMessage) = (@_); + + #Connect to the database and get RT::SystemUser and RT::Nobody loaded + RT::Init; + + require RT::Ticket; + + #Get the current user all loaded + my $CurrentUser = GetCurrentUser(); + + if ( !$CurrentUser->Id ) { + print +loc("No valid RT user found. RT cvs handler disengaged. Please consult your RT administrator.\n"); + return; + } + + my (@commands) = find_commands( \@LogMessage ); + + my ( @tickets, @errors ); + + # Get the list of tickets we're working with out of commands + grep { $_ =~ /^RT-Ticket:\s*(.*?)$/i && push ( @tickets, $1 ) } @commands; + + my $message = new MIME::Entity; + $message->build( + From => $CurrentUser->EmailAddress, + Subject => 'CVS Commit', + Data => \@LogMessage + ); + + # {{{ comment or correspond, as needed + + foreach my $ticket (@tickets) { + my $TicketObj = RT::Ticket->new($CurrentUser); + $TicketObj->Load($ticket); + my ( $id, $msg ); + unless ( $TicketObj->Id ) { + push ( @errors, +"Couldn't load ticket #$ticket. Not adding commit log to ticket history.\n" + ); + } + + if ( $LogMessage[0] =~ /^(comment|private)$/ ) { + ( $id, $msg ) = $TicketObj->Comment( MIMEObj => $message ); + + } + else { + ( $id, $msg ) = $TicketObj->Correspond( MIMEObj => $message ); + } + + push ( @errors, ">> Log message", + "Ticket #" . $TicketObj->Id . ": " . $msg ); + + } + + # }}} + + my ($reply) = ActOnPseudoHeaders( $CurrentUser, @commands ); + print "$reply\n" if ($reply); + print join ( "\n", @errors ); + print "\n"; + +} + +# }}} + +# {{{ sub find_commands + +sub find_commands { + my $lines = shift; + my (@pseudoheaders); + + while ( my $line = shift @{$lines} ) { + next if $line =~ /^\s*?$/; + if ( $line =~ /^RT-/i ) { + + push ( @pseudoheaders, $line ); + } + + #If we find a line that's not a command, get out. + else { + unshift ( @{$lines}, $line ); + last; + } + } + + return (@pseudoheaders); + +} + +# }}} + +# {{{ sub ActOnPseudoHeaders + +=item ActOnPseudoHeaders $PseudoHeaders + +Takes a string of pseudo-headers, iterates through them and does what they tell it to. + +=cut + +sub ActOnPseudoHeaders { + my $CurrentUser = shift; + my (@actions) = (@_); + + my $ResultsMessage = ''; + my $Ticket = RT::Ticket->new($CurrentUser); + + foreach my $action (@actions) { + my ($val); + my $msg = ''; + + $ResultsMessage .= ">>> $action\n"; + + if ( $action =~ /^RT-(.*?):\s*(.*)$/i ) { + my $command = $1; + my $args = $2; + + if ( $command =~ /^ticket$/i ) { + + $val = $Ticket->Load($args); + unless ($val) { + $ResultsMessage .= + loc("ERROR: Couldn't load ticket '[_1]': [_2].\n", $1, $msg); + . loc("Aborting to avoid unintended ticket modifications.\n") + . loc("The following commands were not proccessed:\n\n") + . join ( "\n", @actions ); + return ($ResultsMessage); + } + $ResultsMessage .= loc("Ticket [_1] loaded\n", $Ticket->Id); + } + else { + unless ( $Ticket->Id ) { + $ResultsMessage .= loc("No Ticket specified. Aborting ticket ") + . loc("modifications\n\n") + . loc("The following commands were not proccessed:\n\n") + . join ( "\n", @actions ); + return ($ResultsMessage); + } + + # Deal with the basics + if ( $command =~ /^(Subject|Owner|Status|Queue)$/i ) { + my $method = 'Set' . ucfirst( lc($1) ); + ( $val, $msg ) = $Ticket->$method($args); + } + + # Deal with the dates + elsif ( $command =~ /^(due|starts|started|resolved)$/i ) { + my $method = 'Set' . ucfirst( lc($1) ); + my $date = new RT::Date($CurrentUser); + $date->Set( Format => 'unknown', Value => $args ); + ( $val, $msg ) = $Ticket->$method( $date->ISO ); + } + + # Deal with the watchers + elsif ( $command =~ /^(requestor|requestors|cc|admincc)$/i ) { + my $operator = "+"; + my ($type); + if ( $args =~ /^(\+|\-)(.*)$/ ) { + $operator = $1; + $args = $2; + } + $type = 'Requestor' if ( $command =~ /^requestor/i ); + $type = 'Cc' if ( $command =~ /^cc/i ); + $type = 'AdminCc' if ( $command =~ /^admincc/i ); + + my $user = RT::User->new($CurrentUser); + $user->Load($args); + + if ($operator eq '+') { + ($val, $msg) = $Ticket->AddWatcher( Type => $type, + PrincipalId => $user->PrincipalId); + } elsif ($operator eq '-') { + ($val, $msg) = $Ticket->DeleteWatcher( Type => $type, + PrincipalId => $user->PrincipalId); + } + + } + $ResultsMessage .= $msg . "\n"; + } + + } + return ($ResultsMessage); + +} + +# }}} + +# {{{ sub untaint +sub untaint { + my $val = shift; + + if ( $val =~ /^([-\#\/\w.]+)$/ ) { + $val = $1; # $data now untainted + } + else { + die loc("Bad data in [_1]", $val); # log this somewhere + } + return ($val); +} + +# }}} + +=head1 AUTHOR + + + + rt-commit-handler is a rewritten version of the NetBSD commit handler, + which was placed in the public domain by Charles Hannum. It bore the following + authors statement: + + Contributed by David Hampton <hampton@cisco.com> + Hacked greatly by Greg A. Woods <woods@planix.com> + Rewritten by Charles M. Hannum <mycroft@netbsd.org> + +=cut + diff --git a/rt/bin/rt-commit-handler.in b/rt/bin/rt-commit-handler.in new file mode 100644 index 000000000..02b01abff --- /dev/null +++ b/rt/bin/rt-commit-handler.in @@ -0,0 +1,846 @@ +#!@PERL@ -w +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +# {{{ Docs +# -*-Perl-*- +# +#ident "@(#)ccvs/contrib:$Name: $:$Id: rt-commit-handler.in,v 1.1 2003-07-15 13:16:15 ivan Exp $" +# +# Perl filter to handle the log messages from the checkin of files in multiple +# directories. This script will group the lists of files by log message, and +# send one piece of mail per unique message, no matter how many files are +# committed. + +=head1 NAME rt-commit-handler + +=head1 USAGE + + + +=head2 Regular use + +Stick the following in in CVSROOT/commitinfo + + ALL @RT_BIN_PATH@/rt-commit-handler --record-last-dir + +Stick the following in CVSROOT/loginfo + + ALL @RT_BIN_PATH@/rt-commit-handler --cvs-root /pathtocvs/root --rt %{Vvts} + +=head2 Invocation (advanced use) + +rt-commit-handler --cvs-root /path/to/cvs/root [-d] [-D] [-r] [-M module] \ + [[-m mailto] ...] [[-R replyto] ...] [-f logfile] + + + -d - turn on debugging + -m mailto - send mail to "mailto" (multiple) + -R replyto - set the "Reply-To:" to "replyto" (multiple) + -M modulename - set module name to "modulename" + -f logfile - write commit messages to logfile too + -D - generate diff commands + --rt - invoke RT commit handler + --cvs-root - specify your CVS root + + --record-last-dir - Record the last directory with changes in + pre-commit (commitinfo) mode + + +=cut + +# }}} + +use strict; +use Carp; +use Getopt::Long; +use Text::Wrap; +use Digest::MD5; +use MIME::Entity; + +use lib ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + +use RT::Interface::CLI qw(CleanEnv GetCurrentUser GetMessageContent loc); + +use vars + qw(@MAILER $TMPDIR $FILE_PREFIX $LASTDIR_FILE $HASH_FILE $VERSION_FILE $MESSAGE_FILE $MAIL_FILE $DEBUG $MAILTO $REPLYTO $id $MODULE_NAME + $LOGIN $COMMITLOG $CVS_ROOT $RT_HANDLER); + +#Clean out all the nasties from the environment +CleanEnv(); + +#Load etc/config.pm and drop privs +RT::LoadConfig(); + +#Drop setgid permissions +RT::DropSetGIDPermissions(); + +# {{{ Variable setup +$TMPDIR = '/tmp'; +$FILE_PREFIX = $TMPDIR . '/#cvs.'; + +# The root of your CVS install. we should get this from some smarter place. +# It needs a trailing / + +$LASTDIR_FILE = $FILE_PREFIX . "lastdir"; +$HASH_FILE = $FILE_PREFIX . "hash"; +$VERSION_FILE = $FILE_PREFIX . "version"; +$MESSAGE_FILE = $FILE_PREFIX . "message"; +$MAIL_FILE = $FILE_PREFIX . "mail"; + +$DEBUG = 0; +$RT_HANDLER = 1; + +$MAILTO = ''; + +my @files = (); +my (@log_lines); +my $do_diff = 0; +my $id = getpgrp(); # note, you *must* use a shell which does setpgrp() +$LOGIN = getpwuid($<); + +# }}} + +die "User could not be found" unless ($LOGIN); + +# {{{ parse command line arguments (file list is seen as one arg) +# +while ( my $arg = shift @ARGV ) { + + if ( $arg eq '-d' ) { + $DEBUG = 1; + warn "Debug turned on...\n"; + } + elsif ( $arg =~ /^--record-last-dir$/i ) { + record_last_dir( $id, $ARGV[0] ); + exit(0); + } + elsif ( $arg eq '-m' ) { + $MAILTO .= ", " if $MAILTO; + $MAILTO .= shift @ARGV; + } + elsif ( $arg eq '--rt' ) { + $RT_HANDLER = 1; + } + elsif ( $arg eq '-R' ) { + $REPLYTO .= ", " if $REPLYTO; + $REPLYTO .= shift @ARGV; + } + elsif ( $arg eq '-M' ) { + die ("too many '-M' args\n") if $MODULE_NAME; + $MODULE_NAME = shift @ARGV; + } + elsif ( $arg eq '--cvs-root' ) { + $CVS_ROOT = shift @ARGV; + $CVS_ROOT .= "/" unless ( $CVS_ROOT =~ /\/$/ ); + } + elsif ( $arg eq '-f' ) { + die ("too many '-f' args\n") if $COMMITLOG; + $COMMITLOG = shift @ARGV; + + # This is a disgusting hack to untaint $COMMITLOG if we're running from + # setgid cvs. + $COMMITLOG = untaint($COMMITLOG); + } + elsif ( $arg eq '-D' ) { + $do_diff = 1; + } + else { + @files = split ( ' ', $arg ); + last; + } +} + +# }}} + +$REPLYTO = $LOGIN unless ($REPLYTO); + +# for now, the first "file" is the repository directory being committed, +# relative to the $CVSROOT location +# +my $dir = shift @files; + +# XXX there are some ugly assumptions in here about module names and +# XXX directories relative to the $CVSROOT location -- really should +# XXX read $CVSROOT/CVSROOT/modules, but that's not so easy to do, since +# XXX we have to parse it backwards. +# +# XXX For now we set the `module' name to the top-level directory name. +# +unless ($MODULE_NAME) { + ($MODULE_NAME) = split ( '/', $dir, 2 ); +} + +if ($DEBUG) { + warn "module - ", $MODULE_NAME, "\n"; + warn "dir - ", $dir, "\n"; + warn "files - ", join ( " ", @files ), "\n"; + warn "id - ", $id, "\n"; +} + +# {{{ Check for a new directory or an import command. + +# +# files[0] - "-" +# files[1] - "New" +# files[2] - "directory" +# +# files[0] - "-" +# files[1] - "Imported" +# files[2] - "sources" +# +if ( $files[0] eq "-" ) { + + #we just don't care about New Directory notes + unless ( $files[1] eq "New" && $files[2] eq "directory" ) { + + my @text = (); + + push @text, build_header(); + push @text, ""; + + while ( my $line = <STDIN> ) { + chop $line; # Drop the newline + push @text, $line; + } + + append_logfile( $COMMITLOG, @text ) if ($COMMITLOG); + + mail_notification( $id, @text ); + } + + exit 0; +} + +# }}} + +# {{{ Collect just the log message from stdin. +# + +while ( my $line = <STDIN> ) { + chop $line; # strip the newline + last if ( $line =~ /^Log Message:$/ ); +} +while ( my $line = <STDIN> ) { + chop $line; # strip the newline + $line =~ s/\s+$//; # strip trailing white space + push @log_lines, $line; +} + +my $md5 = Digest::MD5->new(); +foreach my $line (@log_lines) { + $md5->add( $line . "\n" ); +} +my $hash = $md5->hexdigest(); + +warn "hash = $hash\n" if ($DEBUG); + +if ( !-e "$MESSAGE_FILE.$id.$hash" ) { + append_logfile( "$HASH_FILE.$id", $hash ); + write_file( "$MESSAGE_FILE.$id.$hash", @log_lines ); +} + +# }}} + +# Spit out the information gathered in this pass. + +append_logfile( "$VERSION_FILE.$id.$hash", $dir . '/', @files ); + +# {{{ Check whether this is the last directory. If not, quit. + +warn "Checking current dir against last dir $LASTDIR_FILE.$id\n" if ($DEBUG); + +my @last_dir = read_file("$LASTDIR_FILE.$id"); + +unless ($CVS_ROOT) { + die "No cvs root specified with --cvs-root. Can't continue."; +} + +if ( $last_dir[0] ne $CVS_ROOT . $dir ) { + warn "Current directory $CVS_ROOT$dir is not last directory $last_dir[0].\n" + if ($DEBUG); + exit 0; +} + +# }}} + +# {{{ End Of Commits! +# + +# This is it. The commits are all finished. Lump everything together +# into a single message, fire a copy off to the mailing list, and drop +# it on the end of the Changes file. +# + +# +# Produce the final compilation of the log messages +# + +my @hashes = read_file("$HASH_FILE.$id"); +my (@text); + +push @text, build_header(); +push @text, ""; + +my ( @added_files, @modified_files, @removed_files ); + +foreach my $hash (@hashes) { + + # In case we're running setgid, make sure the hash file hasn't been hacked. + $hash =~ m/([a-z0-9]*)/ || die "*** Hacking attempt detected\n"; + $hash = $1; + + my @files = read_file("$VERSION_FILE.$id.$hash"); + my @log_lines = read_file("$MESSAGE_FILE.$id.$hash"); + + my $working_on_dir; # gets set as we iterate through the files. + foreach my $file (@files) { + + #If we've entered a new directory, make a note of that and remove the trailing / + + if ( $file =~ s'\/$'' ) { + $working_on_dir = $file; + next; + } + + my @file_entry = ( split ( ',', $file, 4 ), $working_on_dir ); + + # file_entry looks like ths: + + # 0 1 2 3 4 + # Old rev : new rev : tag: file :directory + my $entry = {}; + $entry->{'old'} = $file_entry[0]; + $entry->{'new'} = $file_entry[1]; + $entry->{'tag'} = $file_entry[2]; + $entry->{'file'} = $file_entry[3]; + $entry->{'dir'} = $file_entry[4]; + + if ( $file_entry[0] eq 'NONE' ) { + $entry->{'old'} = '0'; + push @added_files, $entry; + } + elsif ( $file_entry[1] eq 'NONE' ) { + $entry->{'new'} = '0'; + push @removed_files, $entry; + } + else { + push @modified_files, $entry; + } + } +} + +# }}} + +# {{{ start building up the body + +# Strip leading and trailing blank lines from the log message. Also +# compress multiple blank lines in the body of the message down to a +# single blank line. +# + +my $blank = 1; +@log_lines = map { + my $wasblank = $blank; + $blank = $_ eq ''; + $blank && $wasblank ? () : $_; +} @log_lines; + +pop @log_lines if $blank; + +@modified_files = order_and_summarize_diffs(@modified_files); +@added_files = order_and_summarize_diffs(@added_files); +@removed_files = order_and_summarize_diffs(@removed_files); + +push @text, "Modified Files:", format_lists(@modified_files) + if (@modified_files); + +push @text, "Added Files:", format_lists(@added_files) if (@added_files); + +push @text, "Removed Files:", format_lists(@removed_files) if (@removed_files); + +push @text, "", "Log Message", @log_lines if (@log_lines); + +push @text, ""; + +if ($RT_HANDLER) { + rt_handler( + @log_lines, "\n", + loc("To generate a diff of this commit:\n"), "\n", + format_diffs( @modified_files, @added_files, @removed_files ) + ); +} + +if ($COMMITLOG) { + append_logfile( $COMMITLOG, @text ); +} + +if ($do_diff) { + push @text, ""; + push @text, loc("To generate a diff of this commit:"); + push @text, format_diffs( @modified_files, @added_files, @removed_files ); + push @text, ""; +} + +# }}} + +# {{{ Mail out the notification. + +mail_notification( $id, @text ); + +# }}} + +# {{{ clean up + +unless ($DEBUG) { + $hash = untaint($hash); + $id = untaint($id); + unlink "$VERSION_FILE.$id.$hash"; + unlink "$MESSAGE_FILE.$id.$hash"; + unlink "$MAIL_FILE.$id"; + unlink "$LASTDIR_FILE.$id"; + unlink "$HASH_FILE.$id"; +} + +# }}} + +exit 0; + +# {{{ Subroutines +# + +# {{{ append_logfile +sub append_logfile { + my $filename = shift; + my (@lines) = @_; + + $filename = untaint($filename); + + open( FILE, ">>$filename" ) + || die ("Cannot open file $filename for append.\n"); + foreach my $line (@lines) { + print FILE $line . "\n"; + } + close(FILE); +} + +# }}} + +# {{{ write_file +sub write_file { + my $filename = shift; + my (@lines) = @_; + + $filename = untaint($filename); + + open( FILE, ">$filename" ) + || die ("Cannot open file $filename for write.\n"); + foreach my $line (@lines) { + print FILE $line . "\n"; + } + close(FILE); +} + +# }}} + +# {{{ read_file +sub read_file { + my $filename = shift; + my (@lines); + + open( FILE, "<$filename" ) + || die ("Cannot open file $filename for read.\n"); + while ( my $line = <FILE> ) { + chop $line; + push @lines, $line; + } + close(FILE); + + return (@lines); +} + +# }}} + +# {{{ sub format_lists + +sub format_lists { + my @items = (@_); + + my $files = ""; + map { + $_->{'files'} && ( $files .= ' ' . join ( ' ', @{ $_->{'files'} } ) ); + } @items; + + my @lines = wrap( "\t", "\t\t", $files ); + return (@lines); + +} + +# }}} + +# {{{ sub format_diffs + +sub format_diffs { + my @items = (@_); + + my @lines; + foreach my $item (@items) { + next unless ( $item->{'files'} ); + push ( @lines, + "cvs diff -r" + . $item->{'old'} . " -r" + . $item->{'new'} . " " + . join ( " ", @{ $item->{'files'} } ) . "\n" ); + + } + + @lines = fill( "\t", "\t\t", @lines ); + + return (@lines); +} + +# }}} + +# {{{ sub order_and_summarize_diffs { + +# takes an array of file items +# returns a sorted array of fileset items, which are like file items, except they can have an array of files, rather than +# a singleton file. + +sub order_and_summarize_diffs { + + my @files = (@_); + + # Sort by tag, dir, file. + @files = sort { + $a->{'tag'} cmp $b->{'tag'} + || $a->{'dir'} cmp $b->{'dir'} + || $a->{'file'} cmp $b->{'file'}; + } @files; + + # Combine adjacent rows that are the same modulo the file name. + + my @items = (undef); + + foreach my $file (@files) { + if ( $#items == -1 #if it's empty + || ( !defined $items[-1]->{'old'} + || $items[-1]->{'old'} ne $file->{'old'} ) + || ( !defined $items[-1]->{'new'} + || $items[-1]->{'new'} ne $file->{'new'} ) + || ( !defined $items[-1]->{'tag'} + || $items[-1]->{'tag'} ne $file->{'tag'} ) ) + { + + push ( @items, $file ); + } + push ( @{ $items[-1]->{'files'} }, + $file->{'dir'} . "/" . $file->{'file'} ); + } + + return (@items); +} + +# }}} + +# {{{ build_header + +sub build_header { + my $now = gmtime; + my $header = + sprintf( "Module Name:\t%s\nCommitted By:\t%s\nDate:\t\t%s %s %s", + $MODULE_NAME, $LOGIN, substr( $now, 0, 19 ), "UTC", + substr( $now, 20, 4 ) ); + return ($header); +} + +# }}} + +# {{{ mail_notification +sub mail_notification { + my $id = shift; + my (@text) = @_; + write_file( "$MAIL_FILE.$id", "From: " . $LOGIN, + "Subject: CVS commit: " . $MODULE_NAME, "To: " . $MAILTO, + "Reply-To: " . $REPLYTO, "", "", @text ); + + my $entity = MIME::Entity->build( + From => $LOGIN, + To => $MAILTO, + Subject => "CVS commit: " . $MODULE_NAME, + 'Reply-To' => $REPLYTO, + Data => join ( "\n", @text ) + ); + if ( $RT::MailCommand eq 'sendmailpipe' ) { + open( MAIL, "|$RT::SendmailPath $RT::SendmailArguments" ) + || die "Couldn't send mail: " . $@ . "\n"; + print MAIL $entity->as_string; + close(MAIL); + } + else { + $entity->send( $RT::MailCommand, $RT::MailParams ); + } + +} + +# }}} + +# {{{ sub record_last_dir + +sub record_last_dir { + my $id = shift; + my $dir = shift; + + # make a note of this directory. later, we'll use this to + # figure out if we've gone through the whole commit, + # for something that is a bad mockery of attomic commits. + + warn "about to write $dir to $LASTDIR_FILE.$id" if ($DEBUG); + + write_file( "$LASTDIR_FILE.$id", $dir ); +} + +# }}} + +# {{{ Get the RT stuff set up + +# {{{ sub rt_handler + +sub rt_handler { + my (@LogMessage) = (@_); + + #Connect to the database and get RT::SystemUser and RT::Nobody loaded + RT::Init; + + require RT::Ticket; + + #Get the current user all loaded + my $CurrentUser = GetCurrentUser(); + + if ( !$CurrentUser->Id ) { + print +loc("No valid RT user found. RT cvs handler disengaged. Please consult your RT administrator.\n"); + return; + } + + my (@commands) = find_commands( \@LogMessage ); + + my ( @tickets, @errors ); + + # Get the list of tickets we're working with out of commands + grep { $_ =~ /^RT-Ticket:\s*(.*?)$/i && push ( @tickets, $1 ) } @commands; + + my $message = new MIME::Entity; + $message->build( + From => $CurrentUser->EmailAddress, + Subject => 'CVS Commit', + Data => \@LogMessage + ); + + # {{{ comment or correspond, as needed + + foreach my $ticket (@tickets) { + my $TicketObj = RT::Ticket->new($CurrentUser); + $TicketObj->Load($ticket); + my ( $id, $msg ); + unless ( $TicketObj->Id ) { + push ( @errors, +"Couldn't load ticket #$ticket. Not adding commit log to ticket history.\n" + ); + } + + if ( $LogMessage[0] =~ /^(comment|private)$/ ) { + ( $id, $msg ) = $TicketObj->Comment( MIMEObj => $message ); + + } + else { + ( $id, $msg ) = $TicketObj->Correspond( MIMEObj => $message ); + } + + push ( @errors, ">> Log message", + "Ticket #" . $TicketObj->Id . ": " . $msg ); + + } + + # }}} + + my ($reply) = ActOnPseudoHeaders( $CurrentUser, @commands ); + print "$reply\n" if ($reply); + print join ( "\n", @errors ); + print "\n"; + +} + +# }}} + +# {{{ sub find_commands + +sub find_commands { + my $lines = shift; + my (@pseudoheaders); + + while ( my $line = shift @{$lines} ) { + next if $line =~ /^\s*?$/; + if ( $line =~ /^RT-/i ) { + + push ( @pseudoheaders, $line ); + } + + #If we find a line that's not a command, get out. + else { + unshift ( @{$lines}, $line ); + last; + } + } + + return (@pseudoheaders); + +} + +# }}} + +# {{{ sub ActOnPseudoHeaders + +=item ActOnPseudoHeaders $PseudoHeaders + +Takes a string of pseudo-headers, iterates through them and does what they tell it to. + +=cut + +sub ActOnPseudoHeaders { + my $CurrentUser = shift; + my (@actions) = (@_); + + my $ResultsMessage = ''; + my $Ticket = RT::Ticket->new($CurrentUser); + + foreach my $action (@actions) { + my ($val); + my $msg = ''; + + $ResultsMessage .= ">>> $action\n"; + + if ( $action =~ /^RT-(.*?):\s*(.*)$/i ) { + my $command = $1; + my $args = $2; + + if ( $command =~ /^ticket$/i ) { + + $val = $Ticket->Load($args); + unless ($val) { + $ResultsMessage .= + loc("ERROR: Couldn't load ticket '[_1]': [_2].\n", $1, $msg); + . loc("Aborting to avoid unintended ticket modifications.\n") + . loc("The following commands were not proccessed:\n\n") + . join ( "\n", @actions ); + return ($ResultsMessage); + } + $ResultsMessage .= loc("Ticket [_1] loaded\n", $Ticket->Id); + } + else { + unless ( $Ticket->Id ) { + $ResultsMessage .= loc("No Ticket specified. Aborting ticket ") + . loc("modifications\n\n") + . loc("The following commands were not proccessed:\n\n") + . join ( "\n", @actions ); + return ($ResultsMessage); + } + + # Deal with the basics + if ( $command =~ /^(Subject|Owner|Status|Queue)$/i ) { + my $method = 'Set' . ucfirst( lc($1) ); + ( $val, $msg ) = $Ticket->$method($args); + } + + # Deal with the dates + elsif ( $command =~ /^(due|starts|started|resolved)$/i ) { + my $method = 'Set' . ucfirst( lc($1) ); + my $date = new RT::Date($CurrentUser); + $date->Set( Format => 'unknown', Value => $args ); + ( $val, $msg ) = $Ticket->$method( $date->ISO ); + } + + # Deal with the watchers + elsif ( $command =~ /^(requestor|requestors|cc|admincc)$/i ) { + my $operator = "+"; + my ($type); + if ( $args =~ /^(\+|\-)(.*)$/ ) { + $operator = $1; + $args = $2; + } + $type = 'Requestor' if ( $command =~ /^requestor/i ); + $type = 'Cc' if ( $command =~ /^cc/i ); + $type = 'AdminCc' if ( $command =~ /^admincc/i ); + + my $user = RT::User->new($CurrentUser); + $user->Load($args); + + if ($operator eq '+') { + ($val, $msg) = $Ticket->AddWatcher( Type => $type, + PrincipalId => $user->PrincipalId); + } elsif ($operator eq '-') { + ($val, $msg) = $Ticket->DeleteWatcher( Type => $type, + PrincipalId => $user->PrincipalId); + } + + } + $ResultsMessage .= $msg . "\n"; + } + + } + return ($ResultsMessage); + +} + +# }}} + +# {{{ sub untaint +sub untaint { + my $val = shift; + + if ( $val =~ /^([-\#\/\w.]+)$/ ) { + $val = $1; # $data now untainted + } + else { + die loc("Bad data in [_1]", $val); # log this somewhere + } + return ($val); +} + +# }}} + +=head1 AUTHOR + + + + rt-commit-handler is a rewritten version of the NetBSD commit handler, + which was placed in the public domain by Charles Hannum. It bore the following + authors statement: + + Contributed by David Hampton <hampton@cisco.com> + Hacked greatly by Greg A. Woods <woods@planix.com> + Rewritten by Charles M. Hannum <mycroft@netbsd.org> + +=cut + diff --git a/rt/bin/rt-crontool b/rt/bin/rt-crontool new file mode 100644 index 000000000..cdbc3cbc9 --- /dev/null +++ b/rt/bin/rt-crontool @@ -0,0 +1,220 @@ +#!/usr/bin/perl +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +use Carp; + +use lib ("/opt/rt3/lib", "/opt/rt3/local/lib"); + +package RT; + +use Getopt::Long; + +use RT::Interface::CLI qw(CleanEnv GetCurrentUser GetMessageContent loc); +use RT::Tickets; +use RT::Template; + +#Clean out all the nasties from the environment +CleanEnv(); + +# Load the config file +RT::LoadConfig(); + +#Connect to the database and get RT::SystemUser and RT::Nobody loaded +RT::Init(); + +#Drop setgid permissions +RT::DropSetGIDPermissions(); + +#Get the current user all loaded +my $CurrentUser = GetCurrentUser(); + +unless ( $CurrentUser->Id ) { + print loc("No RT user found. Please consult your RT administrator.\n"); + exit(1); +} + +my ( $search, $condition, $action, $search_arg, $condition_arg, $action_arg, + $template_id, $help, $verbose ); +GetOptions( "search=s" => \$search, + "search-arg=s" => \$search_arg, + "condition=s" => \$condition, + "condition-arg=s" => \$condition_arg, + "action-arg=s" => \$action_arg, + "action=s" => \$action, + "template-id=s" => \$template_id, + "help" => \$help, + "verbose|v" => \$verbose ); + +help() if $help; + +# We _must_ have a search object +load_module($search); +load_module($action) if ($action); +load_module($condition) if ($condition); + +# load template if specified +my $template_obj; +if ($template_id) { + $template_obj = RT::Template->new($RT::Nobody); + $template_obj->LoadById($template_id); +} + +#At the appointed time: + +#find a bunch of tickets +my $tickets = RT::Tickets->new($CurrentUser); +my $search = $search->new( TicketsObj => $tickets, Argument => $search_arg ); + +$search->Prepare(); + +# TicketsFound is an RT::Tickets object +my $tickets = $search->TicketsObj; + +#for each ticket we've found +while ( my $ticket = $tickets->Next() ) { + print "\n" . $ticket->Id() . ": " if ($verbose); + + # perform some more advanced check + if ($condition) { + my $condition_obj = $condition->new( TicketObj => $ticket, + Argument => $condition_arg ); + + # if the condition doesn't apply, get out of here + + next unless ( $condition_obj->IsApplicable ); + print loc("Condition matches...") if ($verbose); + } + + #prepare our action + my $action_obj = $action->new( TicketObj => $ticket, + TemplateObj => $template_obj, + Argument => $action_arg ); + + #if our preparation, move onto the next ticket + next unless ( $action_obj->Prepare ); + print loc("Action prepared...") if ($verbose); + + #commit our action. + next unless ( $action_obj->Commit ); + print loc("Action committed.") if ($verbose); +} + +# {{{ load_module + +=head2 load_module + +Loads a perl module, dying nicely if it can't find it. + +=cut + +sub load_module { + my $modname = shift; + eval "require $modname"; + if ($@) { + die loc( "Failed to load module [_1]. ([_2])", $modname, $@ ); + } + +} + +# }}} + +# {{{ loc + +=head2 loc LIST + +Localize this string, with the current user's currentuser object + +=cut + +sub loc { + $CurrentUser->loc(@_); +} + +# }}} + +sub help { + + print loc( "[_1] is a tool to act on tickets from an external scheduling tool, such as cron.", $0 ) + . "\n"; + print loc("It takes several arguments:") . "\n\n"; + + print " " + . loc( "[_1] - Specify the search module you want to use", "--search" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--search-argument", "--search" ) + . "\n"; + + print " " + . loc( "[_1] - Specify the condition module you want to use", "--condition" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--condition-argument", "--condition" ) + . "\n"; + print " " + . loc( "[_1] - Specify the action module you want to use", "--action" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--action-argument", "--action" ) + . "\n"; + print " " + . loc( "[_1] - Output status updates to STDOUT", "--verbose" ) . "\n"; + print "\n"; + print "\n"; + print loc("Security:")."\n"; + print loc("This tool allows the user to run arbitrary perl modules from within RT.")." ". + loc("If this tool were setgid, a hostile local user could use this tool to gain administrative access to RT.")." ". + loc("It is incredibly important that nonprivileged users not be allowed to run this tool."). " " . + loc("It is suggested that you create a non-privileged unix user with the correct group membership and RT access to run this tool.")."\n"; + print "\n"; + print loc("Example:"); + print "\n"; + print " " + . loc( "The following command will find all active tickets in the queue 'general' and set their priority to 99 if they haven't been touched in 4 hours:" + ) + . "\n\n"; + + print " bin/rt-cron-tool \\\n"; + print + " --search RT::Search::ActiveTicketsInQueue --search-arg general \\\n"; + print + " --condition RT::Condition::UntouchedInHours --condition-arg 4 \\\n"; + print " --action RT::Action::SetPriority --action-arg 99 \\\n"; + print " --verbose\n"; + + print "\n"; + print loc("Escalate tickets"); + print "rt-crontool \\\n"; + print " --search RT::Search::ActiveTicketsInQueue --search-arg thequeuename \\\n"; + print " --action RT::Action::EscalatePriority \\\n"; + + + + + + + exit(0); +} diff --git a/rt/bin/rt-crontool.in b/rt/bin/rt-crontool.in new file mode 100644 index 000000000..8ecc71826 --- /dev/null +++ b/rt/bin/rt-crontool.in @@ -0,0 +1,220 @@ +#!@PERL@ +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; +use Carp; + +use lib ("@RT_LIB_PATH@", "@LOCAL_LIB_PATH@"); + +package RT; + +use Getopt::Long; + +use RT::Interface::CLI qw(CleanEnv GetCurrentUser GetMessageContent loc); +use RT::Tickets; +use RT::Template; + +#Clean out all the nasties from the environment +CleanEnv(); + +# Load the config file +RT::LoadConfig(); + +#Connect to the database and get RT::SystemUser and RT::Nobody loaded +RT::Init(); + +#Drop setgid permissions +RT::DropSetGIDPermissions(); + +#Get the current user all loaded +my $CurrentUser = GetCurrentUser(); + +unless ( $CurrentUser->Id ) { + print loc("No RT user found. Please consult your RT administrator.\n"); + exit(1); +} + +my ( $search, $condition, $action, $search_arg, $condition_arg, $action_arg, + $template_id, $help, $verbose ); +GetOptions( "search=s" => \$search, + "search-arg=s" => \$search_arg, + "condition=s" => \$condition, + "condition-arg=s" => \$condition_arg, + "action-arg=s" => \$action_arg, + "action=s" => \$action, + "template-id=s" => \$template_id, + "help" => \$help, + "verbose|v" => \$verbose ); + +help() if $help; + +# We _must_ have a search object +load_module($search); +load_module($action) if ($action); +load_module($condition) if ($condition); + +# load template if specified +my $template_obj; +if ($template_id) { + $template_obj = RT::Template->new($RT::Nobody); + $template_obj->LoadById($template_id); +} + +#At the appointed time: + +#find a bunch of tickets +my $tickets = RT::Tickets->new($CurrentUser); +my $search = $search->new( TicketsObj => $tickets, Argument => $search_arg ); + +$search->Prepare(); + +# TicketsFound is an RT::Tickets object +my $tickets = $search->TicketsObj; + +#for each ticket we've found +while ( my $ticket = $tickets->Next() ) { + print "\n" . $ticket->Id() . ": " if ($verbose); + + # perform some more advanced check + if ($condition) { + my $condition_obj = $condition->new( TicketObj => $ticket, + Argument => $condition_arg ); + + # if the condition doesn't apply, get out of here + + next unless ( $condition_obj->IsApplicable ); + print loc("Condition matches...") if ($verbose); + } + + #prepare our action + my $action_obj = $action->new( TicketObj => $ticket, + TemplateObj => $template_obj, + Argument => $action_arg ); + + #if our preparation, move onto the next ticket + next unless ( $action_obj->Prepare ); + print loc("Action prepared...") if ($verbose); + + #commit our action. + next unless ( $action_obj->Commit ); + print loc("Action committed.") if ($verbose); +} + +# {{{ load_module + +=head2 load_module + +Loads a perl module, dying nicely if it can't find it. + +=cut + +sub load_module { + my $modname = shift; + eval "require $modname"; + if ($@) { + die loc( "Failed to load module [_1]. ([_2])", $modname, $@ ); + } + +} + +# }}} + +# {{{ loc + +=head2 loc LIST + +Localize this string, with the current user's currentuser object + +=cut + +sub loc { + $CurrentUser->loc(@_); +} + +# }}} + +sub help { + + print loc( "[_1] is a tool to act on tickets from an external scheduling tool, such as cron.", $0 ) + . "\n"; + print loc("It takes several arguments:") . "\n\n"; + + print " " + . loc( "[_1] - Specify the search module you want to use", "--search" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--search-argument", "--search" ) + . "\n"; + + print " " + . loc( "[_1] - Specify the condition module you want to use", "--condition" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--condition-argument", "--condition" ) + . "\n"; + print " " + . loc( "[_1] - Specify the action module you want to use", "--action" ) + . "\n"; + print " " + . loc( "[_1] - An argument to pass to [_2]", "--action-argument", "--action" ) + . "\n"; + print " " + . loc( "[_1] - Output status updates to STDOUT", "--verbose" ) . "\n"; + print "\n"; + print "\n"; + print loc("Security:")."\n"; + print loc("This tool allows the user to run arbitrary perl modules from within RT.")." ". + loc("If this tool were setgid, a hostile local user could use this tool to gain administrative access to RT.")." ". + loc("It is incredibly important that nonprivileged users not be allowed to run this tool."). " " . + loc("It is suggested that you create a non-privileged unix user with the correct group membership and RT access to run this tool.")."\n"; + print "\n"; + print loc("Example:"); + print "\n"; + print " " + . loc( "The following command will find all active tickets in the queue 'general' and set their priority to 99 if they haven't been touched in 4 hours:" + ) + . "\n\n"; + + print " bin/rt-cron-tool \\\n"; + print + " --search RT::Search::ActiveTicketsInQueue --search-arg general \\\n"; + print + " --condition RT::Condition::UntouchedInHours --condition-arg 4 \\\n"; + print " --action RT::Action::SetPriority --action-arg 99 \\\n"; + print " --verbose\n"; + + print "\n"; + print loc("Escalate tickets"); + print "rt-crontool \\\n"; + print " --search RT::Search::ActiveTicketsInQueue --search-arg thequeuename \\\n"; + print " --action RT::Action::EscalatePriority \\\n"; + + + + + + + exit(0); +} diff --git a/rt/bin/rt-mailgate b/rt/bin/rt-mailgate new file mode 100755 index 000000000..8af800227 --- /dev/null +++ b/rt/bin/rt-mailgate @@ -0,0 +1,648 @@ +#!/usr/bin/perl -w +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +=head1 NAME + +rt-mailgate - Mail interface to RT3. + +=begin testing + +use RT::I18N; + +# Make sure that when we call the mailgate wrong, it tempfails + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://bad.address"), "Opened the mailgate - The error below is expected - $@"); +print MAIL <<EOF; +From: root\@localhost +To: rt\@example.com +Subject: This is a test of new ticket creation + +Foob! +EOF +close (MAIL); + +# Check the return value +is ( $? >> 8, 75, "The error message above is expected The mail gateway exited with a failure. yay"); + + +# {{{ Test new ticket creation by root who is privileged and superuser + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: root\@localhost +To: rt\@example.com +Subject: This is a test of new ticket creation + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +use RT::Tickets; +my $tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $tick = $tickets->First(); +ok (UNIVERSAL::isa($tick,'RT::Ticket')); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'This is a test of new ticket creation', "Created the ticket"); + +# }}} + + +# {{{This is a test of new ticket creation as an unknown user + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist\@example.com +To: rt\@example.com +Subject: This is a test of new ticket creation as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0'); +$tick = $tickets->First(); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject ne 'This is a test of new ticket creation as an unknown user', "failed to create the new ticket from an unprivileged account"); +my $u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by failed ticket submission"); + + +# }}} + +# {{{ now everybody can create tickets. can a random unkown user create tickets? + +my $g = RT::Group->new($RT::SystemUser); +$g->LoadSystemInternalGroup('Everyone'); +ok( $g->Id, "Found 'everybody'"); + +my ($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +ok ($val, "Granted everybody the right to create tickets - $msg"); + +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist\@example.com +To: rt\@example.com +Subject: This is a test of new ticket creation as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + + +$tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0'); +$tick = $tickets->First(); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'This is a test of new ticket creation as an unknown user', "failed to create the new ticket from an unprivileged account"); +my $u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist@example.com'); +ok( $u->Id != 0, " user does not exist and was created by ticket submission"); + +# }}} + + +# {{{ can another random reply to a ticket without being granted privs? answer should be no. + + +#($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +#ok ($val, "Granted everybody the right to create tickets - $msg"); +#sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-2\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a reply as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-2@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by ticket correspondence submission"); +# }}} +# {{{ can another random reply to a ticket after being granted privs? answer should be yes + + +($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'ReplyToTicket'); +ok ($val, "Granted everybody the right to reply to tickets - $msg"); +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-2\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a reply as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-2@example.com'); +ok( $u->Id != 0, " user exists and was created by ticket correspondence submission"); + +# }}} + +# {{{ can another random comment on a ticket without being granted privs? answer should be no. + + +#($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +#ok ($val, "Granted everybody the right to create tickets - $msg"); +#sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-3\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a comment as an unknown user + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-3@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by ticket comment submission"); + +# }}} +# {{{ can another random reply to a ticket after being granted privs? answer should be yes + + +($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CommentOnTicket'); +ok ($val, "Granted everybody the right to reply to tickets - $msg"); +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-3\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a comment as an unknown user + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-3@example.com'); +ok( $u->Id != 0, " user exists and was created by ticket comment submission"); + +# }}} + +# {{{ Testing preservation of binary attachments + +# Get a binary blob (Best Practical logo) + +# Create a mime entity with an attachment + +use MIME::Entity; +my $entity = MIME::Entity->build( From => 'root@localhost', + To => 'rt@localhost', + Subject => 'binary attachment test', + Data => ['This is a test of a binary attachment']); + +# currently in lib/t/autogen +$entity->attach(Path => '/opt/rt3/share/html/NoAuth/images/spacer.gif', + Type => 'image/gif', + Encoding => 'base64'); + +# Create a ticket with a binary attachment +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +$entity->print(\*MAIL); + +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); + $tick = $tickets->First(); +ok (UNIVERSAL::isa($tick,'RT::Ticket')); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'binary attachment test', "Created the ticket - ".$tick->Id); + +my $file = `cat ../../../html/NoAuth/images/spacer.gif`; +ok ($file, "Read in the logo image"); + + + use Digest::MD5; +warn "for the raw file the content is ".Digest::MD5::md5_base64($file); + + + +# Verify that the binary attachment is valid in the database +my $attachments = RT::Attachments->new($RT::SystemUser); +$attachments->Limit(FIELD => 'ContentType', VALUE => 'image/gif'); +ok ($attachments->Count == 1, 'Found only one gif in the database'); +my $attachment = $attachments->First; +my $acontent = $attachment->Content; + + warn "coming from the database, the content is ".Digest::MD5::md5_base64($acontent); + +is( $acontent, $file, 'The attachment isn\'t screwed up in the database.'); +# Log in as root +use Getopt::Long; +use LWP::UserAgent; + + +# Grab the binary attachment via the web ui +my $ua = LWP::UserAgent->new(); + +my $full_url = "http://localhost".$RT::WebPath."/Ticket/Attachment/".$attachment->TransactionId."/".$attachment->id."/spacer.gif?&user=root&pass=password"; +my $r = $ua->get( $full_url); + + +# Verify that the downloaded attachment is the same as what we uploaded. +is($file, $r->content, 'The attachment isn\'t screwed up in download'); + + + +# }}} + +# {{{ Simple I18N testing + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +print MAIL <<EOF; +From: root\@localhost +To: rtemail\@example.com +Subject: This is a test of I18N ticket creation +Content-Type: text/plain; charset="utf-8" + +2 accented lines +\303\242\303\252\303\256\303\264\303\273 +\303\241\303\251\303\255\303\263\303\272 +bye +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $unitickets = RT::Tickets->new($RT::SystemUser); +$unitickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$unitickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $unitick = $unitickets->First(); +ok (UNIVERSAL::isa($unitick,'RT::Ticket')); +ok ($unitick->Id, "found ticket ".$unitick->Id); +ok ($unitick->Subject eq 'This is a test of I18N ticket creation', "Created the ticket - ". $unitick->Subject); + + + +my $unistring = "\303\241\303\251\303\255\303\263\303\272"; +Encode::_utf8_on($unistring); +is ($unitick->Transactions->First->Content, $unitick->Transactions->First->Attachments->First->Content, "Content is ". $unitick->Transactions->First->Attachments->First->Content); +ok($unitick->Transactions->First->Attachments->First->Content =~ /$unistring/i, $unitick->Id." appears to be unicode ". $unitick->Transactions->First->Attachments->First->Id); +# supposedly I18N fails on the second message sent in. + +ok(open(MAIL, "|/opt/rt3/bin/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +print MAIL <<EOF; +From: root\@localhost +To: rtemail\@example.com +Subject: This is a test of I18N ticket creation +Content-Type: text/plain; charset="utf-8" + +2 accented lines +\303\242\303\252\303\256\303\264\303\273 +\303\241\303\251\303\255\303\263\303\272 +bye +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $tickets2 = RT::Tickets->new($RT::SystemUser); +$tickets2->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets2->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $tick2 = $tickets2->First(); +ok (UNIVERSAL::isa($tick2,'RT::Ticket')); +ok ($tick2->Id, "found ticket ".$tick2->Id); +ok ($tick2->Subject eq 'This is a test of I18N ticket creation', "Created the ticket"); + + + +my $unistring = "\303\241\303\251\303\255\303\263\303\272"; +Encode::_utf8_on($unistring); + +ok ($tick2->Transactions->First->Content =~ $unistring, "It appears to be unicode - ".$tick2->Transactions->First->Content); + +# }}} + + +($val,$msg) = $g->PrincipalObj->RevokeRight(Right => 'CreateTicket'); +ok ($val, $msg); + + + +=end testing + +=cut + + +use strict; +use Getopt::Long; +use LWP::UserAgent; + +use constant EX_TEMPFAIL => 75; + +my %opts; +GetOptions( \%opts, "queue=s", "action=s", "url=s", "jar=s", "help", "debug", "extension=s", "timeout=i" ); + +if ( $opts{help} ) { + require Pod::Usage; + import Pod::Usage; + pod2usage("RT Mail Gateway\n"); + exit 1; # Don't want to succeed if this is really an email! +} + +for (qw(url)) { + die "$0 invoked improperly\n\nNo $_ provided to mail gateway!\n" unless $opts{$_}; +} + +undef $/; +my $ua = LWP::UserAgent->new(); +$ua->cookie_jar( { file => $opts{jar} } ); + +my %args = ( + queue => $opts{queue}, + action => $opts{action}, + SessionType => 'REST', # Surpress login box +); + +# Read the message in from STDIN +$args{'message'} = <>; + + +if ($opts{'extension'}) { + $args{$opts{'extension'}} = $ENV{'EXTENSION'}; +} + +# Set up cookie here. + +my $full_url = $opts{'url'}. "/REST/1.0/NoAuth/mail-gateway"; +warn "Connecting to $full_url" if $opts{'debug'}; + + + +$ua->timeout(exists($opts{'timeout'}) ? $opts{'timeout'} : 180); +my $r = $ua->post( $full_url, {%args} ); +check_failure($r); + +my $content = $r->content; +warn $content if ($opts{debug}); + +if ( $content !~ /^(ok|not ok)/ ) { + + # It's not the server's fault if the mail is bogus. We just want to know that + # *something* came out of the server. + warn <<EOF; +RT server error. + +The RT server which handled your email did not behave as expected. It +said: + +$content +EOF + +exit EX_TEMPFAIL; + +} + +exit; + + +sub check_failure { + my $r = shift; + return if $r->is_success(); + + # This ordinarily oughtn't to be able to happen, suggests a bug in RT. + # So only load these heavy modules when they're needed. + require HTML::TreeBuilder; + require HTML::FormatText; + + my $error = $r->error_as_HTML; + my $tree = HTML::TreeBuilder->new->parse($error); + $tree->eof; + + # It'll be a cold day in hell before RT sends out bounces in HTML + my $formatter = HTML::FormatText->new( leftmargin => 0, + rightmargin => 50 ); + warn $formatter->format($tree); + warn "This is $0 exiting because of an undefined server error" if ($opts{debug}); + exit EX_TEMPFAIL; +} + + +=head1 SYNOPSIS + + rt-mailgate --help : this text + +Usual invocation (from MTA): + + rt-mailgate --action (correspond|comment) --queue queuename + --url http://your.rt.server/ + [ --debug ] + [ --extension (queue|action|ticket) ] + [ --timeout seconds ] + + + +See C<man rt-mailgate> for more. + +=head1 OPTIONS + +=over 3 + +=item C<--action> + +Specifies whether this is a correspondence or comment address. + +=item C<--queue> + +Reflects which queue this address handles. + +=item C<--url> + +The location of the web server for your RT instance. + + +=item C<--extension> OPTIONAL + +Some MTAs will route mail sent to user-foo@host or user+foo@host to user@host +and present "foo" in the environment variable $EXTENSION. By specifying +the value "queue" for this parameter, the queue this message should be +submitted to will be set to the value of $EXTENSION. By specifying +"ticket", $EXTENSION will be interpreted as the id of the ticket this message +is related to. "action" will allow the user to specify either "comment" or +"correspond" in the address extension. + +=item C<--debug> OPTIONAL + +Print debugging output to standard error + + +=item C<--timeout> OPTIONAL + +Configure the timeout for posting the message to the web server. The +default timeout is 3 minutes (180 seconds). + + +=head1 DESCRIPTION + +The RT mail gateway is the primary mechanism for communicating with RT +via email. This program simply directs the email to the RT web server, +which handles filing correspondence and sending out any required mail. +It is designed to be run as part of the mail delivery process, either +called directly by the MTA or C<procmail>, or in a F<.forward> or +equivalent. + +=head1 SETUP + +Much of the set up of the mail gateway depends on your MTA and mail +routing configuration. However, you will need first of all to create an +RT user for the mail gateway and assign it a password; this helps to +ensure that mail coming into the web server did originate from the +gateway. + +Next, you need to route mail to C<rt-mailgate> for the queues you're +monitoring. For instance, if you're using F</etc/aliases> and you have a +"bugs" queue, you will want something like this: + + bugs: "|/opt/rt3/bin/rt-mailgate --queue bugs --action correspond + --url http://rt.mycorp.com/" + + bugs-comment: "|/opt/rt3/bin/rt-mailgate --queue bugs --action comment + --url http://rt.mycorp.com/" + +Note that you don't have to run your RT server on your mail server, as +the mail gateway will happily relay to a different machine. + +=head1 CUSTOMIZATION + +By default, the mail gateway will accept mail from anyone. However, +there are situations in which you will want to authenticate users +before allowing them to communicate with the system. You can do this +via a plug-in mechanism in the RT configuration. + +You can set the array C<@RT::MailPlugins> to be a list of plugins. The +default plugin, if this is not given, is C<Auth::MailFrom> - that is, +authentication of the person is done based on the C<From> header of the +email. If you have additional filters or authentication mechanisms, you +can list them here and they will be called in order: + + @RT::MailPlugins = ( + "Filter::SpamAssassin", + "Auth::LDAP", + # ... + ); + +See the documentation for any additional plugins you have. + +You may also put Perl subroutines into the C<@RT::MailPlugins> array, if +they behave as described below. + +=head1 WRITING PLUGINS + +What's actually going on in the above is that C<@RT::MailPlugins> is a +list of Perl modules; RT prepends C<RT::Interface::Email::> to the name, +to form a package name, and then C<use>'s this module. The module is +expected to provide a C<GetCurrentUser> subroutine, which takes a hash of +several parameters: + +=over 4 + +=item Message + +A C<MIME::Entity> object representing the email +=item CurrentUser + +An C<RT::CurrentUser> object + +=item AuthStat + +The authentication level returned from the previous plugin. + +=item Ticket [OPTIONAL] + +The ticket under discussion + +=item Queue [OPTIONAL] + +If we don't already have a ticket id, we need to know which queue we're talking about + +=item Action + +The action being performed. At the moment, it's one of "comment" or "correspond" + +=back 4 + +It returns two values, the new C<RT::CurrentUser> object, and the new +authentication level. The authentication level can be zero, not allowed +to communicate with RT at all, (a "permission denied" error is mailed to +the correspondent) or one, which is the normal mode of operation. +Additionally, if C<-1> is returned, then the processing of the plug-ins +stops immediately and the message is ignored. + +=cut + diff --git a/rt/bin/rt-mailgate.in b/rt/bin/rt-mailgate.in new file mode 100644 index 000000000..2ddb604ec --- /dev/null +++ b/rt/bin/rt-mailgate.in @@ -0,0 +1,648 @@ +#!@PERL@ -w +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +=head1 NAME + +rt-mailgate - Mail interface to RT3. + +=begin testing + +use RT::I18N; + +# Make sure that when we call the mailgate wrong, it tempfails + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://bad.address"), "Opened the mailgate - The error below is expected - $@"); +print MAIL <<EOF; +From: root\@localhost +To: rt\@example.com +Subject: This is a test of new ticket creation + +Foob! +EOF +close (MAIL); + +# Check the return value +is ( $? >> 8, 75, "The error message above is expected The mail gateway exited with a failure. yay"); + + +# {{{ Test new ticket creation by root who is privileged and superuser + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: root\@localhost +To: rt\@example.com +Subject: This is a test of new ticket creation + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +use RT::Tickets; +my $tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $tick = $tickets->First(); +ok (UNIVERSAL::isa($tick,'RT::Ticket')); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'This is a test of new ticket creation', "Created the ticket"); + +# }}} + + +# {{{This is a test of new ticket creation as an unknown user + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist\@example.com +To: rt\@example.com +Subject: This is a test of new ticket creation as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0'); +$tick = $tickets->First(); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject ne 'This is a test of new ticket creation as an unknown user', "failed to create the new ticket from an unprivileged account"); +my $u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by failed ticket submission"); + + +# }}} + +# {{{ now everybody can create tickets. can a random unkown user create tickets? + +my $g = RT::Group->new($RT::SystemUser); +$g->LoadSystemInternalGroup('Everyone'); +ok( $g->Id, "Found 'everybody'"); + +my ($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +ok ($val, "Granted everybody the right to create tickets - $msg"); + +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist\@example.com +To: rt\@example.com +Subject: This is a test of new ticket creation as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + + +$tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id' ,OPERATOR => '>', VALUE => '0'); +$tick = $tickets->First(); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'This is a test of new ticket creation as an unknown user', "failed to create the new ticket from an unprivileged account"); +my $u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist@example.com'); +ok( $u->Id != 0, " user does not exist and was created by ticket submission"); + +# }}} + + +# {{{ can another random reply to a ticket without being granted privs? answer should be no. + + +#($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +#ok ($val, "Granted everybody the right to create tickets - $msg"); +#sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-2\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a reply as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-2@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by ticket correspondence submission"); +# }}} +# {{{ can another random reply to a ticket after being granted privs? answer should be yes + + +($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'ReplyToTicket'); +ok ($val, "Granted everybody the right to reply to tickets - $msg"); +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-2\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a reply as an unknown user + +Blah! +Foob! +EOF +close (MAIL); +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-2@example.com'); +ok( $u->Id != 0, " user exists and was created by ticket correspondence submission"); + +# }}} + +# {{{ can another random comment on a ticket without being granted privs? answer should be no. + + +#($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CreateTicket'); +#ok ($val, "Granted everybody the right to create tickets - $msg"); +#sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-3\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a comment as an unknown user + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-3@example.com'); +ok( $u->Id == 0, " user does not exist and was not created by ticket comment submission"); + +# }}} +# {{{ can another random reply to a ticket after being granted privs? answer should be yes + + +($val,$msg) = $g->PrincipalObj->GrantRight(Right => 'CommentOnTicket'); +ok ($val, "Granted everybody the right to reply to tickets - $msg"); +sleep(60); # gotta sleep so the remote process' ACL cache times out + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action comment"), "Opened the mailgate - $@"); +print MAIL <<EOF; +From: doesnotexist-3\@example.com +To: rt\@example.com +Subject: [example.com #@{[$tick->Id]}] This is a test of a comment as an unknown user + +Blah! +Foob! +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +$u = RT::User->new($RT::SystemUser); +$u->Load('doesnotexist-3@example.com'); +ok( $u->Id != 0, " user exists and was created by ticket comment submission"); + +# }}} + +# {{{ Testing preservation of binary attachments + +# Get a binary blob (Best Practical logo) + +# Create a mime entity with an attachment + +use MIME::Entity; +my $entity = MIME::Entity->build( From => 'root@localhost', + To => 'rt@localhost', + Subject => 'binary attachment test', + Data => ['This is a test of a binary attachment']); + +# currently in lib/t/autogen +$entity->attach(Path => '@MASON_HTML_PATH@/NoAuth/images/spacer.gif', + Type => 'image/gif', + Encoding => 'base64'); + +# Create a ticket with a binary attachment +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +$entity->print(\*MAIL); + +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $tickets = RT::Tickets->new($RT::SystemUser); +$tickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); + $tick = $tickets->First(); +ok (UNIVERSAL::isa($tick,'RT::Ticket')); +ok ($tick->Id, "found ticket ".$tick->Id); +ok ($tick->Subject eq 'binary attachment test', "Created the ticket - ".$tick->Id); + +my $file = `cat ../../../html/NoAuth/images/spacer.gif`; +ok ($file, "Read in the logo image"); + + + use Digest::MD5; +warn "for the raw file the content is ".Digest::MD5::md5_base64($file); + + + +# Verify that the binary attachment is valid in the database +my $attachments = RT::Attachments->new($RT::SystemUser); +$attachments->Limit(FIELD => 'ContentType', VALUE => 'image/gif'); +ok ($attachments->Count == 1, 'Found only one gif in the database'); +my $attachment = $attachments->First; +my $acontent = $attachment->Content; + + warn "coming from the database, the content is ".Digest::MD5::md5_base64($acontent); + +is( $acontent, $file, 'The attachment isn\'t screwed up in the database.'); +# Log in as root +use Getopt::Long; +use LWP::UserAgent; + + +# Grab the binary attachment via the web ui +my $ua = LWP::UserAgent->new(); + +my $full_url = "http://localhost".$RT::WebPath."/Ticket/Attachment/".$attachment->TransactionId."/".$attachment->id."/spacer.gif?&user=root&pass=password"; +my $r = $ua->get( $full_url); + + +# Verify that the downloaded attachment is the same as what we uploaded. +is($file, $r->content, 'The attachment isn\'t screwed up in download'); + + + +# }}} + +# {{{ Simple I18N testing + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +print MAIL <<EOF; +From: root\@localhost +To: rtemail\@example.com +Subject: This is a test of I18N ticket creation +Content-Type: text/plain; charset="utf-8" + +2 accented lines +\303\242\303\252\303\256\303\264\303\273 +\303\241\303\251\303\255\303\263\303\272 +bye +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $unitickets = RT::Tickets->new($RT::SystemUser); +$unitickets->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$unitickets->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $unitick = $unitickets->First(); +ok (UNIVERSAL::isa($unitick,'RT::Ticket')); +ok ($unitick->Id, "found ticket ".$unitick->Id); +ok ($unitick->Subject eq 'This is a test of I18N ticket creation', "Created the ticket - ". $unitick->Subject); + + + +my $unistring = "\303\241\303\251\303\255\303\263\303\272"; +Encode::_utf8_on($unistring); +is ($unitick->Transactions->First->Content, $unitick->Transactions->First->Attachments->First->Content, "Content is ". $unitick->Transactions->First->Attachments->First->Content); +ok($unitick->Transactions->First->Attachments->First->Content =~ /$unistring/i, $unitick->Id." appears to be unicode ". $unitick->Transactions->First->Attachments->First->Id); +# supposedly I18N fails on the second message sent in. + +ok(open(MAIL, "|@RT_BIN_PATH@/rt-mailgate --url http://localhost".$RT::WebPath."/ --queue general --action correspond"), "Opened the mailgate - $@"); + +print MAIL <<EOF; +From: root\@localhost +To: rtemail\@example.com +Subject: This is a test of I18N ticket creation +Content-Type: text/plain; charset="utf-8" + +2 accented lines +\303\242\303\252\303\256\303\264\303\273 +\303\241\303\251\303\255\303\263\303\272 +bye +EOF +close (MAIL); + +#Check the return value +is ($? >> 8, 0, "The mail gateway exited normally. yay"); + +my $tickets2 = RT::Tickets->new($RT::SystemUser); +$tickets2->OrderBy(FIELD => 'id', ORDER => 'DESC'); +$tickets2->Limit(FIELD => 'id', OPERATOR => '>', VALUE => '0'); +my $tick2 = $tickets2->First(); +ok (UNIVERSAL::isa($tick2,'RT::Ticket')); +ok ($tick2->Id, "found ticket ".$tick2->Id); +ok ($tick2->Subject eq 'This is a test of I18N ticket creation', "Created the ticket"); + + + +my $unistring = "\303\241\303\251\303\255\303\263\303\272"; +Encode::_utf8_on($unistring); + +ok ($tick2->Transactions->First->Content =~ $unistring, "It appears to be unicode - ".$tick2->Transactions->First->Content); + +# }}} + + +($val,$msg) = $g->PrincipalObj->RevokeRight(Right => 'CreateTicket'); +ok ($val, $msg); + + + +=end testing + +=cut + + +use strict; +use Getopt::Long; +use LWP::UserAgent; + +use constant EX_TEMPFAIL => 75; + +my %opts; +GetOptions( \%opts, "queue=s", "action=s", "url=s", "jar=s", "help", "debug", "extension=s", "timeout=i" ); + +if ( $opts{help} ) { + require Pod::Usage; + import Pod::Usage; + pod2usage("RT Mail Gateway\n"); + exit 1; # Don't want to succeed if this is really an email! +} + +for (qw(url)) { + die "$0 invoked improperly\n\nNo $_ provided to mail gateway!\n" unless $opts{$_}; +} + +undef $/; +my $ua = LWP::UserAgent->new(); +$ua->cookie_jar( { file => $opts{jar} } ); + +my %args = ( + queue => $opts{queue}, + action => $opts{action}, + SessionType => 'REST', # Surpress login box +); + +# Read the message in from STDIN +$args{'message'} = <>; + + +if ($opts{'extension'}) { + $args{$opts{'extension'}} = $ENV{'EXTENSION'}; +} + +# Set up cookie here. + +my $full_url = $opts{'url'}. "/REST/1.0/NoAuth/mail-gateway"; +warn "Connecting to $full_url" if $opts{'debug'}; + + + +$ua->timeout(exists($opts{'timeout'}) ? $opts{'timeout'} : 180); +my $r = $ua->post( $full_url, {%args} ); +check_failure($r); + +my $content = $r->content; +warn $content if ($opts{debug}); + +if ( $content !~ /^(ok|not ok)/ ) { + + # It's not the server's fault if the mail is bogus. We just want to know that + # *something* came out of the server. + warn <<EOF; +RT server error. + +The RT server which handled your email did not behave as expected. It +said: + +$content +EOF + +exit EX_TEMPFAIL; + +} + +exit; + + +sub check_failure { + my $r = shift; + return if $r->is_success(); + + # This ordinarily oughtn't to be able to happen, suggests a bug in RT. + # So only load these heavy modules when they're needed. + require HTML::TreeBuilder; + require HTML::FormatText; + + my $error = $r->error_as_HTML; + my $tree = HTML::TreeBuilder->new->parse($error); + $tree->eof; + + # It'll be a cold day in hell before RT sends out bounces in HTML + my $formatter = HTML::FormatText->new( leftmargin => 0, + rightmargin => 50 ); + warn $formatter->format($tree); + warn "This is $0 exiting because of an undefined server error" if ($opts{debug}); + exit EX_TEMPFAIL; +} + + +=head1 SYNOPSIS + + rt-mailgate --help : this text + +Usual invocation (from MTA): + + rt-mailgate --action (correspond|comment) --queue queuename + --url http://your.rt.server/ + [ --debug ] + [ --extension (queue|action|ticket) ] + [ --timeout seconds ] + + + +See C<man rt-mailgate> for more. + +=head1 OPTIONS + +=over 3 + +=item C<--action> + +Specifies whether this is a correspondence or comment address. + +=item C<--queue> + +Reflects which queue this address handles. + +=item C<--url> + +The location of the web server for your RT instance. + + +=item C<--extension> OPTIONAL + +Some MTAs will route mail sent to user-foo@host or user+foo@host to user@host +and present "foo" in the environment variable $EXTENSION. By specifying +the value "queue" for this parameter, the queue this message should be +submitted to will be set to the value of $EXTENSION. By specifying +"ticket", $EXTENSION will be interpreted as the id of the ticket this message +is related to. "action" will allow the user to specify either "comment" or +"correspond" in the address extension. + +=item C<--debug> OPTIONAL + +Print debugging output to standard error + + +=item C<--timeout> OPTIONAL + +Configure the timeout for posting the message to the web server. The +default timeout is 3 minutes (180 seconds). + + +=head1 DESCRIPTION + +The RT mail gateway is the primary mechanism for communicating with RT +via email. This program simply directs the email to the RT web server, +which handles filing correspondence and sending out any required mail. +It is designed to be run as part of the mail delivery process, either +called directly by the MTA or C<procmail>, or in a F<.forward> or +equivalent. + +=head1 SETUP + +Much of the set up of the mail gateway depends on your MTA and mail +routing configuration. However, you will need first of all to create an +RT user for the mail gateway and assign it a password; this helps to +ensure that mail coming into the web server did originate from the +gateway. + +Next, you need to route mail to C<rt-mailgate> for the queues you're +monitoring. For instance, if you're using F</etc/aliases> and you have a +"bugs" queue, you will want something like this: + + bugs: "|/opt/rt3/bin/rt-mailgate --queue bugs --action correspond + --url http://rt.mycorp.com/" + + bugs-comment: "|/opt/rt3/bin/rt-mailgate --queue bugs --action comment + --url http://rt.mycorp.com/" + +Note that you don't have to run your RT server on your mail server, as +the mail gateway will happily relay to a different machine. + +=head1 CUSTOMIZATION + +By default, the mail gateway will accept mail from anyone. However, +there are situations in which you will want to authenticate users +before allowing them to communicate with the system. You can do this +via a plug-in mechanism in the RT configuration. + +You can set the array C<@RT::MailPlugins> to be a list of plugins. The +default plugin, if this is not given, is C<Auth::MailFrom> - that is, +authentication of the person is done based on the C<From> header of the +email. If you have additional filters or authentication mechanisms, you +can list them here and they will be called in order: + + @RT::MailPlugins = ( + "Filter::SpamAssassin", + "Auth::LDAP", + # ... + ); + +See the documentation for any additional plugins you have. + +You may also put Perl subroutines into the C<@RT::MailPlugins> array, if +they behave as described below. + +=head1 WRITING PLUGINS + +What's actually going on in the above is that C<@RT::MailPlugins> is a +list of Perl modules; RT prepends C<RT::Interface::Email::> to the name, +to form a package name, and then C<use>'s this module. The module is +expected to provide a C<GetCurrentUser> subroutine, which takes a hash of +several parameters: + +=over 4 + +=item Message + +A C<MIME::Entity> object representing the email +=item CurrentUser + +An C<RT::CurrentUser> object + +=item AuthStat + +The authentication level returned from the previous plugin. + +=item Ticket [OPTIONAL] + +The ticket under discussion + +=item Queue [OPTIONAL] + +If we don't already have a ticket id, we need to know which queue we're talking about + +=item Action + +The action being performed. At the moment, it's one of "comment" or "correspond" + +=back 4 + +It returns two values, the new C<RT::CurrentUser> object, and the new +authentication level. The authentication level can be zero, not allowed +to communicate with RT at all, (a "permission denied" error is mailed to +the correspondent) or one, which is the normal mode of operation. +Additionally, if C<-1> is returned, then the processing of the plug-ins +stops immediately and the message is ignored. + +=cut + diff --git a/rt/bin/rt.in b/rt/bin/rt.in new file mode 100644 index 000000000..90369b5b3 --- /dev/null +++ b/rt/bin/rt.in @@ -0,0 +1,1816 @@ +#!@PERL@ -w +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; + +# This program is intentionally written to have as few non-core module +# dependencies as possible. It should stay that way. + +use Cwd; +use LWP; +use HTTP::Request::Common; + +# We derive configuration information from hardwired defaults, dotfiles, +# and the RT* environment variables (in increasing order of precedence). +# Session information is stored in ~/.rt_sessions. + +my $VERSION = 0.02; +my $HOME = eval{(getpwuid($<))[7]} + || $ENV{HOME} || $ENV{LOGDIR} || $ENV{HOMEPATH} + || "."; +my %config = ( + ( + debug => 0, + user => eval{(getpwuid($<))[0]} || $ENV{USER} || $ENV{USERNAME}, + passwd => undef, + server => 'http://localhost/rt/', + ), + config_from_file($ENV{RTCONFIG} || ".rtrc"), + config_from_env() +); +my $session = new Session("$HOME/.rt_sessions"); +my $REST = "$config{server}/REST/1.0"; + +sub whine; +sub DEBUG { warn @_ if $config{debug} >= shift } + +# These regexes are used by command handlers to parse arguments. +# (XXX: Ask Autrijus how i18n changes these definitions.) + +my $name = '[\w.-]+'; +my $field = '[a-zA-Z][a-zA-Z0-9_-]*'; +my $label = '[a-zA-Z0-9@_.+-]+'; +my $labels = "(?:$label,)*$label"; +my $idlist = '(?:(?:\d+-)?\d+,)*(?:\d+-)?\d+'; + +# Our command line looks like this: +# +# rt <action> [options] [arguments] +# +# We'll parse just enough of it to decide upon an action to perform, and +# leave the rest to per-action handlers to interpret appropriately. + +my %handlers = ( +# handler => [ ...aliases... ], + version => ["version", "ver"], + logout => ["logout"], + help => ["help", "man"], + show => ["show", "cat"], + edit => ["create", "edit", "new", "ed"], + list => ["search", "list", "ls"], + comment => ["comment", "correspond"], + link => ["link", "ln"], + merge => ["merge"], + grant => ["grant", "revoke"], +); + +# Once we find and call an appropriate handler, we're done. + +my (%actions, $action); +foreach my $fn (keys %handlers) { + foreach my $alias (@{ $handlers{$fn} }) { + $actions{$alias} = \&{"$fn"}; + } +} +if (@ARGV && exists $actions{$ARGV[0]}) { + $action = shift @ARGV; +} +$actions{$action || "help"}->($action || ()); +exit; + +# Handler functions. +# ------------------ +# +# The following subs are handlers for each entry in %actions. + +sub version { + print "rt $VERSION\n"; +} + +sub logout { + submit("$REST/logout") if defined $session->cookie; +} + +sub help { + my ($action, $type) = @_; + my (%help, $key); + + # What help topics do we know about? + local $/ = undef; + foreach my $item (@{ Form::parse(<DATA>) }) { + my $title = $item->[2]{Title}; + my @titles = ref $title eq 'ARRAY' ? @$title : $title; + + foreach $title (grep $_, @titles) { + $help{$title} = $item->[2]{Text}; + } + } + + # What does the user want help with? + undef $action if ($action && $actions{$action} eq \&help); + unless ($action || $type) { + # If we don't know, we'll look for clues in @ARGV. + foreach (@ARGV) { + if (exists $help{$_}) { $key = $_; last; } + } + unless ($key) { + # Tolerate possibly plural words. + foreach (@ARGV) { + if ($_ =~ s/s$// && exists $help{$_}) { $key = $_; last; } + } + } + } + + if ($type && $action) { + $key = "$type.$action"; + } + $key ||= $type || $action || "introduction"; + + # Find a suitable topic to display. + while (!exists $help{$key}) { + if ($type && $action) { + if ($key eq "$type.$action") { $key = $action; } + elsif ($key eq $action) { $key = $type; } + else { $key = "introduction"; } + } + else { + $key = "introduction"; + } + } + + print STDERR $help{$key}, "\n\n"; +} + +# Displays a list of objects that match some specified condition. + +sub list { + my ($q, $type, %data, $orderby); + my $bad = 0; + + while (@ARGV) { + $_ = shift @ARGV; + + if (/^-t$/) { + $bad = 1, last unless defined($type = get_type_argument()); + } + elsif (/^-S$/) { + $bad = 1, last unless get_var_argument(\%data); + } + elsif (/^-o$/) { + $orderby = shift @ARGV; + } + elsif (/^-([isl])$/) { + $data{format} = $1; + } + elsif (/^-f$/) { + if ($ARGV[0] !~ /^(?:(?:$field,)*$field)$/) { + whine "No valid field list in '-f $ARGV[0]'."; + $bad = 1; last; + } + $data{fields} = shift @ARGV; + } + elsif (!defined $q && !/^-/) { + $q = $_; + } + else { + my $datum = /^-/ ? "option" : "argument"; + whine "Unrecognised $datum '$_'."; + $bad = 1; last; + } + } + + $type ||= "ticket"; + unless ($type && defined $q) { + my $item = $type ? "query string" : "object type"; + whine "No $item specified."; + $bad = 1; + } + return help("list", $type) if $bad; + + my $r = submit("$REST/search/$type", { query => $q, %data, orderby => $orderby || "" }); + print $r->content; +} + +# Displays selected information about a single object. + +sub show { + my ($type, @objects, %data); + my $slurped = 0; + my $bad = 0; + + while (@ARGV) { + $_ = shift @ARGV; + + if (/^-t$/) { + $bad = 1, last unless defined($type = get_type_argument()); + } + elsif (/^-S$/) { + $bad = 1, last unless get_var_argument(\%data); + } + elsif (/^-([isl])$/) { + $data{format} = $1; + } + elsif (/^-$/ && !$slurped) { + chomp(my @lines = <STDIN>); + foreach (@lines) { + unless (is_object_spec($_, $type)) { + whine "Invalid object on STDIN: '$_'."; + $bad = 1; last; + } + push @objects, $_; + } + $slurped = 1; + } + elsif (/^-f$/) { + if ($ARGV[0] !~ /^(?:(?:$field,)*$field)$/) { + whine "No valid field list in '-f $ARGV[0]'."; + $bad = 1; last; + } + $data{fields} = shift @ARGV; + } + elsif (my $spec = is_object_spec($_, $type)) { + push @objects, $spec; + } + else { + my $datum = /^-/ ? "option" : "argument"; + whine "Unrecognised $datum '$_'."; + $bad = 1; last; + } + } + + unless (@objects) { + whine "No objects specified."; + $bad = 1; + } + return help("show", $type) if $bad; + + my $r = submit("$REST/show", { id => \@objects, %data }); + print $r->content; +} + +# To create a new object, we ask the server for a form with the defaults +# filled in, allow the user to edit it, and send the form back. +# +# To edit an object, we must ask the server for a form representing that +# object, make changes requested by the user (either on the command line +# or interactively via $EDITOR), and send the form back. + +sub edit { + my ($action) = @_; + my (%data, $type, @objects); + my ($cl, $text, $edit, $input, $output); + + use vars qw(%set %add %del); + %set = %add = %del = (); + my $slurped = 0; + my $bad = 0; + + while (@ARGV) { + $_ = shift @ARGV; + + if (/^-e$/) { $edit = 1 } + elsif (/^-i$/) { $input = 1 } + elsif (/^-o$/) { $output = 1 } + elsif (/^-t$/) { + $bad = 1, last unless defined($type = get_type_argument()); + } + elsif (/^-S$/) { + $bad = 1, last unless get_var_argument(\%data); + } + elsif (/^-$/ && !($slurped || $input)) { + chomp(my @lines = <STDIN>); + foreach (@lines) { + unless (is_object_spec($_, $type)) { + whine "Invalid object on STDIN: '$_'."; + $bad = 1; last; + } + push @objects, $_; + } + $slurped = 1; + } + elsif (/^set$/i) { + my $vars = 0; + + while (@ARGV && $ARGV[0] =~ /^($field)([+-]?=)(.*)$/) { + my ($key, $op, $val) = ($1, $2, $3); + my $hash = ($op eq '=') ? \%set : ($op =~ /^\+/) ? \%add : \%del; + + vpush($hash, lc $key, $val); + shift @ARGV; + $vars++; + } + unless ($vars) { + whine "No variables to set."; + $bad = 1; last; + } + $cl = $vars; + } + elsif (/^(?:add|del)$/i) { + my $vars = 0; + my $hash = ($_ eq "add") ? \%add : \%del; + + while (@ARGV && $ARGV[0] =~ /^($field)=(.*)$/) { + my ($key, $val) = ($1, $2); + + vpush($hash, lc $key, $val); + shift @ARGV; + $vars++; + } + unless ($vars) { + whine "No variables to set."; + $bad = 1; last; + } + $cl = $vars; + } + elsif (my $spec = is_object_spec($_, $type)) { + push @objects, $spec; + } + else { + my $datum = /^-/ ? "option" : "argument"; + whine "Unrecognised $datum '$_'."; + $bad = 1; last; + } + } + + if ($action =~ /^ed(?:it)?$/) { + unless (@objects) { + whine "No objects specified."; + $bad = 1; + } + } + else { + if (@objects) { + whine "You shouldn't specify objects as arguments to $action."; + $bad = 1; + } + unless ($type) { + whine "What type of object do you want to create?"; + $bad = 1; + } + @objects = ("$type/new"); + } + return help($action, $type) if $bad; + + # We need a form to make changes to. We usually ask the server for + # one, but we can avoid that if we are fed one on STDIN, or if the + # user doesn't want to edit the form by hand, and the command line + # specifies only simple variable assignments. + + if ($input) { + local $/ = undef; + $text = <STDIN>; + } + elsif ($edit || %add || %del || !$cl) { + my $r = submit("$REST/show", { id => \@objects, format => 'l' }); + $text = $r->content; + } + + # If any changes were specified on the command line, apply them. + if ($cl) { + if ($text) { + # We're updating forms from the server. + my $forms = Form::parse($text); + + foreach my $form (@$forms) { + my ($c, $o, $k, $e) = @$form; + my ($key, $val); + + next if ($e || !@$o); + + local %add = %add; + local %del = %del; + local %set = %set; + + # Make changes to existing fields. + foreach $key (@$o) { + if (exists $add{lc $key}) { + $val = delete $add{lc $key}; + vpush($k, $key, $val); + $k->{$key} = vsplit($k->{$key}) if $val =~ /[,\n]/; + } + if (exists $del{lc $key}) { + $val = delete $del{lc $key}; + my %val = map {$_=>1} @{ vsplit($val) }; + $k->{$key} = vsplit($k->{$key}); + @{$k->{$key}} = grep {!exists $val{$_}} @{$k->{$key}}; + } + if (exists $set{lc $key}) { + $k->{$key} = delete $set{lc $key}; + } + } + + # Then update the others. + foreach $key (keys %set) { vpush($k, $key, $set{$key}) } + foreach $key (keys %add) { + vpush($k, $key, $add{$key}); + $k->{$key} = vsplit($k->{$key}); + } + push @$o, (keys %add, keys %set); + } + + $text = Form::compose($forms); + } + else { + # We're rolling our own set of forms. + my @forms; + foreach (@objects) { + my ($type, $ids, $args) = + m{^($name)/($idlist|$labels)(?:(/.*))?$}o; + + $args ||= ""; + foreach my $obj (expand_list($ids)) { + my %set = (%set, id => "$type/$obj$args"); + push @forms, ["", [keys %set], \%set]; + } + } + $text = Form::compose(\@forms); + } + } + + if ($output) { + print $text; + exit; + } + + my $synerr = 0; + +EDIT: + # We'll let the user edit the form before sending it to the server, + # unless we have enough information to submit it non-interactively. + if ($edit || (!$input && !$cl)) { + my $newtext = vi($text); + # We won't resubmit a bad form unless it was changed. + $text = ($synerr && $newtext eq $text) ? undef : $newtext; + } + + if ($text) { + my $r = submit("$REST/edit", {content => $text, %data}); + if ($r->code == 409) { + # If we submitted a bad form, we'll give the user a chance + # to correct it and resubmit. + if ($edit || (!$input && !$cl)) { + $text = $r->content; + $synerr = 1; + goto EDIT; + } + else { + print $r->content; + exit -1; + } + } + print $r->content; + } +} + +# We roll "comment" and "correspond" into the same handler. + +sub comment { + my ($action) = @_; + my (%data, $id, @files, @bcc, @cc, $msg, $wtime, $edit); + my $bad = 0; + + while (@ARGV) { + $_ = shift @ARGV; + + if (/^-e$/) { + $edit = 1; + } + elsif (/^-[abcmw]$/) { + unless (@ARGV) { + whine "No argument specified with $_."; + $bad = 1; last; + } + + if (/-a/) { + unless (-f $ARGV[0] && -r $ARGV[0]) { + whine "Cannot read attachment: '$ARGV[0]'."; + exit -1; + } + push @files, shift @ARGV; + } + elsif (/-([bc])/) { + my $a = $_ eq "-b" ? \@bcc : \@cc; + @$a = split /\s*,\s*/, shift @ARGV; + } + elsif (/-m/) { $msg = shift @ARGV } + elsif (/-w/) { $wtime = shift @ARGV } + } + elsif (!$id && m|^(?:ticket/)?($idlist)$|) { + $id = $1; + } + else { + my $datum = /^-/ ? "option" : "argument"; + whine "Unrecognised $datum '$_'."; + $bad = 1; last; + } + } + + unless ($id) { + whine "No object specified."; + $bad = 1; + } + return help($action, "ticket") if $bad; + + my $form = [ + "", + [ "Ticket", "Action", "Cc", "Bcc", "Attachment", "TimeWorked", "Text" ], + { + Ticket => $id, + Action => $action, + Cc => [ @cc ], + Bcc => [ @bcc ], + Attachment => [ @files ], + TimeWorked => $wtime || '', + Text => $msg || '', + } + ]; + + my $text = Form::compose([ $form ]); + + if ($edit || !$msg) { + my $error = 0; + my ($c, $o, $k, $e); + + do { + my $ntext = vi($text); + exit if ($error && $ntext eq $text); + $text = $ntext; + $form = Form::parse($text); + $error = 0; + + ($c, $o, $k, $e) = @{ $form->[0] }; + if ($e) { + $error = 1; + $c = "# Syntax error."; + goto NEXT; + } + elsif (!@$o) { + exit; + } + @files = @{ vsplit($k->{Attachment}) }; + + NEXT: + $text = Form::compose([[$c, $o, $k, $e]]); + } while ($error); + } + + my $i = 1; + foreach my $file (@files) { + $data{"attachment_$i"} = bless([ $file ], "Attachment"); + $i++; + } + $data{content} = $text; + + my $r = submit("$REST/ticket/comment/$id", \%data); + print $r->content; +} + +# Merge one ticket into another. + +sub merge { + my @id; + my $bad = 0; + + while (@ARGV) { + $_ = shift @ARGV; + + if (/^\d+$/) { + push @id, $_; + } + else { + whine "Unrecognised argument: '$_'."; + $bad = 1; last; + } + } + + unless (@id == 2) { + my $evil = @id > 2 ? "many" : "few"; + whine "Too $evil arguments specified."; + $bad = 1; + } + return help("merge", "ticket") if $bad; + + my $r = submit("$REST/ticket/merge/$id[0]", {into => $id[1]}); + print $r->content; +} + +# Link one ticket to another. + +sub link { + my ($bad, $del, %data) = (0, 0, ()); + my %ltypes = map { lc $_ => $_ } qw(DependsOn DependedOnBy RefersTo + ReferredToBy HasMember MemberOf); + + while (@ARGV && $ARGV[0] =~ /^-/) { + $_ = shift @ARGV; + + if (/^-d$/) { + $del = 1; + } + else { + whine "Unrecognised option: '$_'."; + $bad = 1; last; + } + } + + if (@ARGV == 3) { + my ($from, $rel, $to) = @ARGV; + if ($from !~ /^\d+$/ || $to !~ /^\d+$/) { + my $bad = $from =~ /^\d+$/ ? $to : $from; + whine "Invalid ticket ID '$bad' specified."; + $bad = 1; + } + unless (exists $ltypes{lc $rel}) { + whine "Invalid relationship '$rel' specified."; + $bad = 1; + } + %data = (id => $from, rel => $rel, to => $to, del => $del); + } + else { + my $bad = @ARGV < 3 ? "few" : "many"; + whine "Too $bad arguments specified."; + $bad = 1; + } + return help("link", "ticket") if $bad; + + my $r = submit("$REST/ticket/link", \%data); + print $r->content; +} + +# Grant/revoke a user's rights. + +sub grant { + my ($cmd) = @_; + + my $revoke = 0; + while (@ARGV) { + } + + $revoke = 1 if $cmd->{action} eq 'revoke'; +} + +# Client <-> Server communication. +# -------------------------------- +# +# This function composes and sends an HTTP request to the RT server, and +# interprets the response. It takes a request URI, and optional request +# data (a string, or a reference to a set of key-value pairs). + +sub submit { + my ($uri, $content) = @_; + my ($req, $data); + my $ua = new LWP::UserAgent(agent => "RT/3.0b", env_proxy => 1); + + # Did the caller specify any data to send with the request? + $data = []; + if (defined $content) { + unless (ref $content) { + # If it's just a string, make sure LWP handles it properly. + # (By pretending that it's a file!) + $content = [ content => [undef, "", Content => $content] ]; + } + elsif (ref $content eq 'HASH') { + my @data; + foreach my $k (keys %$content) { + if (ref $content->{$k} eq 'ARRAY') { + foreach my $v (@{ $content->{$k} }) { + push @data, $k, $v; + } + } + else { push @data, $k, $content->{$k} } + } + $content = \@data; + } + $data = $content; + } + + # Should we send authentication information to start a new session? + if (!defined $session->cookie) { + push @$data, ( user => $config{user} ); + push @$data, ( pass => $config{passwd} || read_passwd() ); + } + + # Now, we construct the request. + if (@$data) { + $req = POST($uri, $data, Content_Type => 'form-data'); + } + else { + $req = GET($uri); + } + $session->add_cookie_header($req); + + # Then we send the request and parse the response. + DEBUG(3, $req->as_string); + my $res = $ua->request($req); + DEBUG(3, $res->as_string); + + if ($res->is_success) { + # The content of the response we get from the RT server consists + # of an HTTP-like status line followed by optional header lines, + # a blank line, and arbitrary text. + + my ($head, $text) = split /\n\n/, $res->content, 2; + my ($status, @headers) = split /\n/, $head; + $text =~ s/\n*$/\n/; + + # "RT/3.0.1 401 Credentials required" + if ($status !~ m#^RT/\d+(?:\.\d+)+(?:-?\w+)? (\d+) ([\w\s]+)$#) { + warn "rt: Malformed RT response from $config{server}.\n"; + warn "(Rerun with RTDEBUG=3 for details.)\n" if $config{debug} < 3; + exit -1; + } + + # Our caller can pretend that the server returned a custom HTTP + # response code and message. (Doing that directly is apparently + # not sufficiently portable and uncomplicated.) + $res->code($1); + $res->message($2); + $res->content($text); + $session->update($res) if ($res->is_success || $res->code != 401); + + if (!$res->is_success) { + # We can deal with authentication failures ourselves. Either + # we sent invalid credentials, or our session has expired. + if ($res->code == 401) { + my %d = @$data; + if (exists $d{user}) { + warn "rt: Incorrect username or password.\n"; + exit -1; + } + elsif ($req->header("Cookie")) { + # We'll retry the request with credentials, unless + # we only wanted to logout in the first place. + $session->delete; + return submit(@_) unless $uri eq "$REST/logout"; + } + } + # Conflicts should be dealt with by the handler and user. + # For anything else, we just die. + elsif ($res->code != 409) { + warn "rt: ", $res->content; + exit; + } + } + } + else { + warn "rt: Server error: ", $res->message, " (", $res->code, ")\n"; + exit -1; + } + + return $res; +} + +# Session management. +# ------------------- +# +# Maintains a list of active sessions in the ~/.rt_sessions file. +{ + package Session; + my ($s, $u); + + # Initialises the session cache. + sub new { + my ($class, $file) = @_; + my $self = { + file => $file || "$HOME/.rt_sessions", + sids => { } + }; + + # The current session is identified by the currently configured + # server and user. + ($s, $u) = @config{"server", "user"}; + + bless $self, $class; + $self->load(); + + return $self; + } + + # Returns the current session cookie. + sub cookie { + my ($self) = @_; + my $cookie = $self->{sids}{$s}{$u}; + return defined $cookie ? "RT_SID=$cookie" : undef; + } + + # Deletes the current session cookie. + sub delete { + my ($self) = @_; + delete $self->{sids}{$s}{$u}; + } + + # Adds a Cookie header to an outgoing HTTP request. + sub add_cookie_header { + my ($self, $request) = @_; + my $cookie = $self->cookie(); + + $request->header(Cookie => $cookie) if defined $cookie; + } + + # Extracts the Set-Cookie header from an HTTP response, and updates + # session information accordingly. + sub update { + my ($self, $response) = @_; + my $cookie = $response->header("Set-Cookie"); + + if (defined $cookie && $cookie =~ /^RT_SID=([0-9A-Fa-f]+);/) { + $self->{sids}{$s}{$u} = $1; + } + } + + # Loads the session cache from the specified file. + sub load { + my ($self, $file) = @_; + $file ||= $self->{file}; + local *F; + + open(F, $file) && do { + $self->{file} = $file; + my $sids = $self->{sids} = {}; + while (<F>) { + chomp; + next if /^$/ || /^#/; + next unless m#^https?://[^ ]+ \w+ [0-9A-Fa-f]+$#; + my ($server, $user, $cookie) = split / /, $_; + $sids->{$server}{$user} = $cookie; + } + return 1; + }; + return 0; + } + + # Writes the current session cache to the specified file. + sub save { + my ($self, $file) = shift; + $file ||= $self->{file}; + local *F; + + open(F, ">$file") && do { + my $sids = $self->{sids}; + foreach my $server (keys %$sids) { + foreach my $user (keys %{ $sids->{$server} }) { + my $sid = $sids->{$server}{$user}; + if (defined $sid) { + print F "$server $user $sid\n"; + } + } + } + close(F); + chmod 0600, $file; + return 1; + }; + return 0; + } + + sub DESTROY { + my $self = shift; + $self->save; + } +} + +# Form handling. +# -------------- +# +# Forms are RFC822-style sets of (field, value) specifications with some +# initial comments and interspersed blank lines allowed for convenience. +# Sets of forms are separated by --\n (in a cheap parody of MIME). +# +# Each form is parsed into an array with four elements: commented text +# at the start of the form, an array with the order of keys, a hash with +# key/value pairs, and optional error text if the form syntax was wrong. + +# Returns a reference to an array of parsed forms. +sub Form::parse { + my $state = 0; + my @forms = (); + my @lines = split /\n/, $_[0]; + my ($c, $o, $k, $e) = ("", [], {}, ""); + + LINE: + while (@lines) { + my $line = shift @lines; + + next LINE if $line eq ''; + + if ($line eq '--') { + # We reached the end of one form. We'll ignore it if it was + # empty, and store it otherwise, errors and all. + if ($e || $c || @$o) { + push @forms, [ $c, $o, $k, $e ]; + $c = ""; $o = []; $k = {}; $e = ""; + } + $state = 0; + } + elsif ($state != -1) { + if ($state == 0 && $line =~ /^#/) { + # Read an optional block of comments (only) at the start + # of the form. + $state = 1; + $c = $line; + while (@lines && $lines[0] =~ /^#/) { + $c .= "\n".shift @lines; + } + $c .= "\n"; + } + elsif ($state <= 1 && $line =~ /^($field):(?:\s+(.*))?$/) { + # Read a field: value specification. + my $f = $1; + my @v = ($2 || ()); + + # Read continuation lines, if any. + while (@lines && ($lines[0] eq '' || $lines[0] =~ /^\s+/)) { + push @v, shift @lines; + } + pop @v while (@v && $v[-1] eq ''); + + # Strip longest common leading indent from text. + my $ws = ""; + foreach my $ls (map {/^(\s+)/} @v[1..$#v]) { + $ws = $ls if (!$ws || length($ls) < length($ws)); + } + s/^$ws// foreach @v; + + push(@$o, $f) unless exists $k->{$f}; + vpush($k, $f, join("\n", @v)); + + $state = 1; + } + elsif ($line !~ /^#/) { + # We've found a syntax error, so we'll reconstruct the + # form parsed thus far, and add an error marker. (>>) + $state = -1; + $e = Form::compose([[ "", $o, $k, "" ]]); + $e.= $line =~ /^>>/ ? "$line\n" : ">> $line\n"; + } + } + else { + # We saw a syntax error earlier, so we'll accumulate the + # contents of this form until the end. + $e .= "$line\n"; + } + } + push(@forms, [ $c, $o, $k, $e ]) if ($e || $c || @$o); + + foreach my $l (keys %$k) { + $k->{$l} = vsplit($k->{$l}) if (ref $k->{$l} eq 'ARRAY'); + } + + return \@forms; +} + +# Returns text representing a set of forms. +sub Form::compose { + my ($forms) = @_; + my @text; + + foreach 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; + + foreach my $key (@$o) { + my ($line, $sp); + my $v = $k->{$key}; + my @values = ref $v eq 'ARRAY' ? @$v : $v; + + $sp = " "x(length("$key: ")); + $sp = " "x4 if length($sp) > 16; + + foreach $v (@values) { + if ($v =~ /\n/) { + $v =~ s/^/$sp/gm; + $v =~ s/^$sp//; + + if ($line) { + push @lines, "$line\n\n"; + $line = ""; + } + elsif (@lines && $lines[-1] !~ /\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 =~ /\n/) { + if (@lines && $lines[-1] !~ /\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; +} + +# Configuration. +# -------------- + +# Returns configuration information from the environment. +sub config_from_env { + my %env; + + foreach my $k ("DEBUG", "USER", "PASSWD", "SERVER") { + if (exists $ENV{"RT$k"}) { + $env{lc $k} = $ENV{"RT$k"}; + } + } + + return %env; +} + +# Finds a suitable configuration file and returns information from it. +sub config_from_file { + my ($rc) = @_; + + if ($rc =~ m#^/#) { + # We'll use an absolute path if we were given one. + return parse_config_file($rc); + } + else { + # Otherwise we'll use the first file we can find in the current + # directory, or in one of its (increasingly distant) ancestors. + + my @dirs = split /\//, cwd; + while (@dirs) { + my $file = join('/', @dirs, $rc); + if (-r $file) { + return parse_config_file($file); + } + + # Remove the last directory component each time. + pop @dirs; + } + + # Still nothing? We'll fall back to some likely defaults. + for ("$HOME/$rc", "/etc/rt.conf") { + return parse_config_file($_) if (-r $_); + } + } + + return (); +} + +# Makes a hash of the specified configuration file. +sub parse_config_file { + my %cfg; + my ($file) = @_; + + open(CFG, $file) && do { + while (<CFG>) { + chomp; + next if (/^#/ || /^\s*$/); + + if (/^(user|passwd|server)\s+([^ ]+)$/) { + $cfg{$1} = $2; + } + else { + die "rt: $file:$.: unknown configuration directive.\n"; + } + } + }; + + return %cfg; +} + +# Helper functions. +# ----------------- + +sub whine { + my $sub = (caller(1))[3]; + $sub =~ s/^main:://; + warn "rt: $sub: @_\n"; + return; +} + +sub read_passwd { + eval 'require Term::ReadKey'; + if ($@) { + die "No password specified (and Term::ReadKey not installed).\n"; + } + + print "Password: "; + Term::ReadKey::ReadMode('noecho'); + chomp(my $passwd = Term::ReadKey::ReadLine(0)); + Term::ReadKey::ReadMode('restore'); + print "\n"; + + return $passwd; +} + +sub vi { + my ($text) = @_; + my $file = "/tmp/rt.form.$$"; + my $editor = $ENV{EDITOR} || $ENV{VISUAL} || "vi"; + + local *F; + local $/ = undef; + + open(F, ">$file") || die "$file: $!\n"; print F $text; close(F); + system($editor, $file) && die "Couldn't run $editor.\n"; + open(F, $file) || die "$file: $!\n"; $text = <F>; close(F); + unlink($file); + + return $text; +} + +# Add a value to a (possibly multi-valued) hash key. +sub vpush { + my ($hash, $key, $val) = @_; + my @val = ref $val eq 'ARRAY' ? @$val : $val; + + if (exists $hash->{$key}) { + unless (ref $hash->{$key} eq 'ARRAY') { + my @v = $hash->{$key} ne '' ? $hash->{$key} : (); + $hash->{$key} = \@v; + } + push @{ $hash->{$key} }, @val; + } + else { + $hash->{$key} = $val; + } +} + +# "Normalise" a hash key that's known to be multi-valued. +sub vsplit { + my ($val) = @_; + my ($word, @words); + my @values = ref $val eq 'ARRAY' ? @$val : $val; + + foreach my $line (map {split /\n/} @values) { + # XXX: This should become a real parser, à la Text::ParseWords. + $line =~ s/^\s+//; + $line =~ s/\s+$//; + push @words, split /\s*,\s*/, $line; + } + + return \@words; +} + +sub expand_list { + my ($list) = @_; + my ($elt, @elts, %elts); + + foreach $elt (split /,/, $list) { + if ($elt =~ /^(\d+)-(\d+)$/) { push @elts, ($1..$2) } + else { push @elts, $elt } + } + + @elts{@elts}=(); + return sort {$a<=>$b} keys %elts; +} + +sub get_type_argument { + my $type; + + if (@ARGV) { + $type = shift @ARGV; + unless ($type =~ /^[A-Za-z0-9_.-]+$/) { + # We want whine to mention our caller, not us. + @_ = ("Invalid type '$type' specified."); + goto &whine; + } + } + else { + @_ = ("No type argument specified with -t."); + goto &whine; + } + + $type =~ s/s$//; # "Plural". Ugh. + return $type; +} + +sub get_var_argument { + my ($data) = @_; + + if (@ARGV) { + my $kv = shift @ARGV; + if (my ($k, $v) = $kv =~ /^($field)=(.*)$/) { + push @{ $data->{$k} }, $v; + } + else { + @_ = ("Invalid variable specification: '$kv'."); + goto &whine; + } + } + else { + @_ = ("No variable argument specified with -S."); + goto &whine; + } +} + +sub is_object_spec { + my ($spec, $type) = @_; + + $spec =~ s|^(?:$type/)?|$type/| if defined $type; + return $spec if ($spec =~ m{^$name/(?:$idlist|$labels)(?:/.*)?$}o); + return; +} + +__DATA__ + +Title: intro +Title: introduction +Text: + + ** THIS IS AN UNSUPPORTED PREVIEW RELEASE ** + ** PLEASE REPORT BUGS TO rt-bugs@fsck.com ** + + This is a command-line interface to RT 3. + + It allows you to interact with an RT server over HTTP, and offers an + interface to RT's functionality that is better-suited to automation + and integration with other tools. + + In general, each invocation of this program should specify an action + to perform on one or more objects, and any other arguments required + to complete the desired action. + + For more information: + + - rt help actions (a list of possible actions) + - rt help objects (how to specify objects) + - rt help usage (syntax information) + + - rt help config (configuration details) + - rt help examples (a few useful examples) + - rt help topics (a list of help topics) + +-- + +Title: usage +Title: syntax +Text: + + Syntax: + + rt <action> [options] [arguments] + + Each invocation of this program must specify an action (e.g. "edit", + "create"), options to modify behaviour, and other arguments required + by the specified action. (For example, most actions expect a list of + numeric object IDs to act upon.) + + The details of the syntax and arguments for each action are given by + "rt help <action>". Some actions may be referred to by more than one + name ("create" is the same as "new", for example). + + Objects are identified by a type and an ID (which can be a name or a + number, depending on the type). For some actions, the object type is + implied (you can only comment on tickets); for others, the user must + specify it explicitly. See "rt help objects" for details. + + In syntax descriptions, mandatory arguments that must be replaced by + appropriate value are enclosed in <>, and optional arguments are + indicated by [] (for example, <action> and [options] above). + + For more information: + + - rt help objects (how to specify objects) + - rt help actions (a list of actions) + - rt help types (a list of object types) + +-- + +Title: conf +Title: config +Title: configuration +Text: + + This program has two major sources of configuration information: its + configuration files, and the environment. + + The program looks for configuration directives in a file named .rtrc + (or $RTCONFIG; see below) in the current directory, and then in more + distant ancestors, until it reaches /. If no suitable configuration + files are found, it will also check for ~/.rtrc and /etc/rt.conf. + + Configuration directives: + + The following directives may occur, one per line: + + - server <URL> URL to RT server. + - user <username> RT username. + - passwd <passwd> RT user's password. + + Blank and #-commented lines are ignored. + + Environment variables: + + The following environment variables override any corresponding + values defined in configuration files: + + - RTUSER + - RTPASSWD + - RTSERVER + - RTDEBUG Numeric debug level. (Set to 3 for full logs.) + - RTCONFIG Specifies a name other than ".rtrc" for the + configuration file. + +-- + +Title: objects +Text: + + Syntax: + + <type>/<id>[/<attributes>] + + Every object in RT has a type (e.g. "ticket", "queue") and a numeric + ID. Some types of objects can also be identified by name (like users + and queues). Furthermore, objects may have named attributes (such as + "ticket/1/history"). + + An object specification is like a path in a virtual filesystem, with + object types as top-level directories, object IDs as subdirectories, + and named attributes as further subdirectories. + + A comma-separated list of names, numeric IDs, or numeric ranges can + be used to specify more than one object of the same type. Note that + the list must be a single argument (i.e., no spaces). For example, + "user/root,1-3,5,7-10,ams" is a list of ten users; the same list + can also be written as "user/ams,root,1,2,3,5,7,8-20". + + Examples: + + ticket/1 + ticket/1/attachments + ticket/1/attachments/3 + ticket/1/attachments/3/content + ticket/1-3/links + ticket/1-3,5-7/history + + user/ams + user/ams/rights + user/ams,rai,1/rights + + For more information: + + - rt help <action> (action-specific details) + - rt help <type> (type-specific details) + +-- + +Title: actions +Title: commands +Text: + + You can currently perform the following actions on all objects: + + - list (list objects matching some condition) + - show (display object details) + - edit (edit object details) + - create (create a new object) + + Each type may define actions specific to itself; these are listed in + the help item about that type. + + For more information: + + - rt help <action> (action-specific details) + - rt help types (a list of possible types) + +-- + +Title: types +Text: + + You can currently operate on the following types of objects: + + - tickets + - users + - groups + - queues + + For more information: + + - rt help <type> (type-specific details) + - rt help objects (how to specify objects) + - rt help actions (a list of possible actions) + +-- + +Title: ticket +Text: + + Tickets are identified by a numeric ID. + + The following generic operations may be performed upon tickets: + + - list + - show + - edit + - create + + In addition, the following ticket-specific actions exist: + + - link + - merge + - comment + - correspond + + Attributes: + + The following attributes can be used with "rt show" or "rt edit" + to retrieve or edit other information associated with tickets: + + links A ticket's relationships with others. + history All of a ticket's transactions. + history/type/<type> Only a particular type of transaction. + history/id/<id> Only the transaction of the specified id. + attachments A list of attachments. + attachments/<id> The metadata for an individual attachment. + attachments/<id>/content The content of an individual attachment. + +-- + +Title: user +Title: group +Text: + + Users and groups are identified by name or numeric ID. + + The following generic operations may be performed upon them: + + - list + - show + - edit + - create + + In addition, the following type-specific actions exist: + + - grant + - revoke + + Attributes: + + The following attributes can be used with "rt show" or "rt edit" + to retrieve or edit other information associated with users and + groups: + + rights Global rights granted to this user. + rights/<queue> Queue rights for this user. + +-- + +Title: queue +Text: + + Queues are identified by name or numeric ID. + + Currently, they can be subjected to the following actions: + + - show + - edit + - create + +-- + +Title: logout +Text: + + Syntax: + + rt logout + + Terminates the currently established login session. You will need to + provide authentication credentials before you can continue using the + server. (See "rt help config" for details about authentication.) + +-- + +Title: ls +Title: list +Title: search +Text: + + Syntax: + + rt <ls|list|search> [options] "query string" + + Displays a list of objects matching the specified conditions. + ("ls", "list", and "search" are synonyms.) + + Conditions are expressed in the SQL-like syntax used internally by + RT3. (For more information, see "rt help query".) The query string + must be supplied as one argument. + + (Right now, the server doesn't support listing anything but tickets. + Other types will be supported in future; this client will be able to + take advantage of that support without any changes.) + + Options: + + The following options control how much information is displayed + about each matching object: + + -i Numeric IDs only. (Useful for |rt edit -; see examples.) + -s Short description. + -l Longer description. + + In addition, + + -o +/-<field> Orders the returned list by the specified field. + -S var=val Submits the specified variable with the request. + -t type Specifies the type of object to look for. (The + default is "ticket".) + + Examples: + + rt ls "Priority > 5 and Status='new'" + rt ls -o +Subject "Priority > 5 and Status='new'" + rt ls -o -Created "Priority > 5 and Status='new'" + rt ls -i "Priority > 5"|rt edit - set status=resolved + rt ls -t ticket "Subject like '[PATCH]%'" + +-- + +Title: show +Text: + + Syntax: + + rt show [options] <object-ids> + + Displays details of the specified objects. + + For some types, object information is further classified into named + attributes (for example, "1-3/links" is a valid ticket specification + that refers to the links for tickets 1-3). Consult "rt help <type>" + and "rt help objects" for further details. + + This command writes a set of forms representing the requested object + data to STDOUT. + + Options: + + - Read IDs from STDIN instead of the command-line. + -t type Specifies object type. + -f a,b,c Restrict the display to the specified fields. + -S var=val Submits the specified variable with the request. + + Examples: + + rt show -t ticket -f id,subject,status 1-3 + rt show ticket/3/attachments/29 + rt show ticket/3/attachments/29/content + rt show ticket/1-3/links + rt show -t user 2 + +-- + +Title: new +Title: edit +Title: create +Text: + + Syntax: + + rt edit [options] <object-ids> set field=value [field=value] ... + add field=value [field=value] ... + del field=value [field=value] ... + + Edits information corresponding to the specified objects. + + If, instead of "edit", an action of "new" or "create" is specified, + then a new object is created. In this case, no numeric object IDs + may be specified, but the syntax and behaviour remain otherwise + unchanged. + + This command typically starts an editor to allow you to edit object + data in a form for submission. If you specified enough information + on the command-line, however, it will make the submission directly. + + The command line may specify field-values in three different ways. + "set" sets the named field to the given value, "add" adds a value + to a multi-valued field, and "del" deletes the corresponding value. + Each "field=value" specification must be given as a single argument. + + For some types, object information is further classified into named + attributes (for example, "1-3/links" is a valid ticket specification + that refers to the links for tickets 1-3). These attributes may also + be edited. Consult "rt help <type>" and "rt help object" for further + details. + + Options: + + - Read numeric IDs from STDIN instead of the command-line. + (Useful with rt ls ... | rt edit -; see examples below.) + -i Read a completed form from STDIN before submitting. + -o Dump the completed form to STDOUT instead of submitting. + -e Allows you to edit the form even if the command-line has + enough information to make a submission directly. + -S var=val + Submits the specified variable with the request. + -t type Specifies object type. + + Examples: + + # Interactive (starts $EDITOR with a form). + rt edit ticket/3 + rt create -t ticket + + # Non-interactive. + rt edit ticket/1-3 add cc=foo@example.com set priority=3 + rt ls -t tickets -i 'Priority > 5' | rt edit - set status=resolved + rt edit ticket/4 set priority=3 owner=bar@example.com \ + add cc=foo@example.com bcc=quux@example.net + rt create -t ticket subject='new ticket' priority=10 \ + add cc=foo@example.com + +-- + +Title: comment +Title: correspond +Text: + + Syntax: + + rt <comment|correspond> [options] <ticket-id> + + Adds a comment (or correspondence) to the specified ticket (the only + difference being that comments aren't sent to the requestors.) + + This command will typically start an editor and allow you to type a + comment into a form. If, however, you specified all the necessary + information on the command line, it submits the comment directly. + + (See "rt help forms" for more information about forms.) + + Options: + + -m <text> Specify comment text. + -a <file> Attach a file to the comment. (May be used more + than once to attach multiple files.) + -c <addrs> A comma-separated list of Cc addresses. + -b <addrs> A comma-separated list of Bcc addresses. + -w <time> Specify the time spent working on this ticket. + -e Starts an editor before the submission, even if + arguments from the command line were sufficient. + + Examples: + + rt comment -t 'Not worth fixing.' -a stddisclaimer.h 23 + +-- + +Title: merge +Text: + + Syntax: + + rt merge <from-id> <to-id> + + Merges the two specified tickets. + +-- + +Title: link +Text: + + Syntax: + + rt link [-d] <id-A> <relationship> <id-B> + + Creates (or, with -d, deletes) a link between the specified tickets. + The relationship can (irrespective of case) be any of: + + DependsOn/DependedOnBy: A depends upon B (or vice versa). + RefersTo/ReferredToBy: A refers to B (or vice versa). + MemberOf/HasMember: A is a member of B (or vice versa). + + To view a ticket's relationships, use "rt show ticket/3/links". (See + "rt help ticket" and "rt help show".) + + Options: + + -d Deletes the specified link. + + Examples: + + rt link 2 dependson 3 + rt link -d 4 referredtoby 6 # 6 no longer refers to 4 + +-- + +Title: grant +Title: revoke +Text: + +-- + +Title: query +Text: + + RT3 uses an SQL-like syntax to specify object selection constraints. + See the <RT:...> documentation for details. + + (XXX: I'm going to have to write it, aren't I?) + +-- + +Title: form +Title: forms +Text: + + This program uses RFC822 header-style forms to represent object data + in a form that's suitable for processing both by humans and scripts. + + A form is a set of (field, value) specifications, with some initial + commented text and interspersed blank lines allowed for convenience. + Field names may appear more than once in a form; a comma-separated + list of multiple field values may also be specified directly. + + Field values can be wrapped as in RFC822, with leading whitespace. + The longest sequence of leading whitespace common to all the lines + is removed (preserving further indentation). There is no limit on + the length of a value. + + Multiple forms are separated by a line containing only "--\n". + + (XXX: A more detailed specification will be provided soon. For now, + the server-side syntax checking will suffice.) + +-- + +Title: topics +Text: + + Use "rt help <topic>" for help on any of the following subjects: + + - tickets, users, groups, queues. + - show, edit, ls/list/search, new/create. + + - query (search query syntax) + - forms (form specification) + + - objects (how to specify objects) + - types (a list of object types) + - actions/commands (a list of actions) + - usage/syntax (syntax details) + - conf/config/configuration (configuration details) + - examples (a few useful examples) + +-- + +Title: example +Title: examples +Text: + + This section will be filled in with useful examples, once it becomes + more clear what examples may be useful. + + For the moment, please consult examples provided with each action. + +-- diff --git a/rt/bin/webmux.pl b/rt/bin/webmux.pl new file mode 100755 index 000000000..96e7ebf8d --- /dev/null +++ b/rt/bin/webmux.pl @@ -0,0 +1,148 @@ +#!/usr/bin/perl +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; + +BEGIN { + $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need + $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'}; + $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; + $ENV{'ENV'} = '' if defined $ENV{'ENV'}; + $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + +} + +use lib ("/opt/rt3/local/lib", "/opt/rt3/lib"); +use RT; + +package RT::Mason; + +use CGI qw(-private_tempfiles); #bring this in before mason, to make sure we + #set private_tempfiles + +BEGIN { + if ($mod_perl::VERSION >= 1.9908) { + require Apache::RequestUtil; + no warnings 'redefine'; + my $sub = *Apache::request{CODE}; + *Apache::request = sub { + my $r; + eval { $r = $sub->('Apache'); }; + # warn $@ if $@; + return $r; + }; + } + if ($CGI::MOD_PERL) { + require HTML::Mason::ApacheHandler; + } + else { + require HTML::Mason::CGIHandler; + } +} + +use HTML::Mason; # brings in subpackages: Parser, Interp, etc. + +use vars qw($Nobody $SystemUser $r); + +#This drags in RT's config.pm +RT::LoadConfig(); + +use Carp; + +{ + package HTML::Mason::Commands; + use vars qw(%session); + + use RT::Tickets; + use RT::Transactions; + use RT::Users; + use RT::CurrentUser; + use RT::Templates; + use RT::Queues; + use RT::ScripActions; + use RT::ScripConditions; + use RT::Scrips; + use RT::Groups; + use RT::GroupMembers; + use RT::CustomFields; + use RT::CustomFieldValues; + use RT::TicketCustomFieldValues; + + use RT::Interface::Web; + use MIME::Entity; + use Text::Wrapper; + use CGI::Cookie; + use Time::ParseDate; + use HTML::Entities; +} + + +# Activate the following if running httpd as root (the normal case). +# Resets ownership of all files created by Mason at startup. +# Note that mysql uses DB for sessions, so there's no need to do this. +unless ($RT::DatabaseType =~ /(mysql|Pg)/) { + # Clean up our umask to protect session files + umask(0077); + +if ( $CGI::MOD_PERL) { + chown( Apache->server->uid, Apache->server->gid, [$RT::MasonSessionDir] ) + if Apache->server->can('uid'); + } + # Die if WebSessionDir doesn't exist or we can't write to it + stat($RT::MasonSessionDir); + die "Can't read and write $RT::MasonSessionDir" + unless ( ( -d _ ) and ( -r _ ) and ( -w _ ) ); +} + +my $ah = &RT::Interface::Web::NewApacheHandler(@RT::MasonParameters) if $CGI::MOD_PERL; + +sub handler { + ($r) = @_; + + local $SIG{__WARN__}; + local $SIG{__DIE__}; + + RT::Init(); + + # We don't need to handle non-text items + return -1 if defined( $r->content_type ) && $r->content_type !~ m|^text/|io; + + my %session; + my $status; + eval { $status = $ah->handle_request($r) }; + if ($@) { + $RT::Logger->crit($@); + } + + undef (%session); + + if ($RT::Handle->TransactionDepth) { + $RT::Handle->ForceRollback; + $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") ; + } + return $status; +} + +1; diff --git a/rt/bin/webmux.pl.in b/rt/bin/webmux.pl.in new file mode 100644 index 000000000..dca5705e9 --- /dev/null +++ b/rt/bin/webmux.pl.in @@ -0,0 +1,148 @@ +#!@PERL@ +# BEGIN LICENSE BLOCK +# +# Copyright (c) 1996-2003 Jesse Vincent <jesse@bestpractical.com> +# +# (Except where explictly superceded by other copyright notices) +# +# This work is made available to you under the terms of Version 2 of +# the GNU General Public License. A copy of that license should have +# been provided with this software, but in any event can be snarfed +# from www.gnu.org. +# +# This work 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. +# +# Unless otherwise specified, all modifications, corrections or +# extensions to this work which alter its source code become the +# property of Best Practical Solutions, LLC when submitted for +# inclusion in the work. +# +# +# END LICENSE BLOCK + +use strict; + +BEGIN { + $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need + $ENV{'CDPATH'} = '' if defined $ENV{'CDPATH'}; + $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'}; + $ENV{'ENV'} = '' if defined $ENV{'ENV'}; + $ENV{'IFS'} = '' if defined $ENV{'IFS'}; + @ORACLE_ENV_PREF@ +} + +use lib ("@LOCAL_LIB_PATH@", "@RT_LIB_PATH@"); +use RT; + +package RT::Mason; + +use CGI qw(-private_tempfiles); #bring this in before mason, to make sure we + #set private_tempfiles + +BEGIN { + if ($mod_perl::VERSION >= 1.9908) { + require Apache::RequestUtil; + no warnings 'redefine'; + my $sub = *Apache::request{CODE}; + *Apache::request = sub { + my $r; + eval { $r = $sub->('Apache'); }; + # warn $@ if $@; + return $r; + }; + } + if ($CGI::MOD_PERL) { + require HTML::Mason::ApacheHandler; + } + else { + require HTML::Mason::CGIHandler; + } +} + +use HTML::Mason; # brings in subpackages: Parser, Interp, etc. + +use vars qw($Nobody $SystemUser $r); + +#This drags in RT's config.pm +RT::LoadConfig(); + +use Carp; + +{ + package HTML::Mason::Commands; + use vars qw(%session); + + use RT::Tickets; + use RT::Transactions; + use RT::Users; + use RT::CurrentUser; + use RT::Templates; + use RT::Queues; + use RT::ScripActions; + use RT::ScripConditions; + use RT::Scrips; + use RT::Groups; + use RT::GroupMembers; + use RT::CustomFields; + use RT::CustomFieldValues; + use RT::TicketCustomFieldValues; + + use RT::Interface::Web; + use MIME::Entity; + use Text::Wrapper; + use CGI::Cookie; + use Time::ParseDate; + use HTML::Entities; +} + + +# Activate the following if running httpd as root (the normal case). +# Resets ownership of all files created by Mason at startup. +# Note that mysql uses DB for sessions, so there's no need to do this. +unless ($RT::DatabaseType =~ /(mysql|Pg)/) { + # Clean up our umask to protect session files + umask(0077); + +if ( $CGI::MOD_PERL) { + chown( Apache->server->uid, Apache->server->gid, [$RT::MasonSessionDir] ) + if Apache->server->can('uid'); + } + # Die if WebSessionDir doesn't exist or we can't write to it + stat($RT::MasonSessionDir); + die "Can't read and write $RT::MasonSessionDir" + unless ( ( -d _ ) and ( -r _ ) and ( -w _ ) ); +} + +my $ah = &RT::Interface::Web::NewApacheHandler(@RT::MasonParameters) if $CGI::MOD_PERL; + +sub handler { + ($r) = @_; + + local $SIG{__WARN__}; + local $SIG{__DIE__}; + + RT::Init(); + + # We don't need to handle non-text items + return -1 if defined( $r->content_type ) && $r->content_type !~ m|^text/|io; + + my %session; + my $status; + eval { $status = $ah->handle_request($r) }; + if ($@) { + $RT::Logger->crit($@); + } + + undef (%session); + + if ($RT::Handle->TransactionDepth) { + $RT::Handle->ForceRollback; + $RT::Logger->crit("Transaction not committed. Usually indicates a software fault. Data loss may have occurred") ; + } + return $status; +} + +1; |