]>
Commit | Line | Data |
---|---|---|
84fb5b46 MKG |
1 | # BEGIN BPS TAGGED BLOCK {{{ |
2 | # | |
3 | # COPYRIGHT: | |
4 | # | |
5 | # This software is Copyright (c) 1996-2012 Best Practical Solutions, LLC | |
6 | # <sales@bestpractical.com> | |
7 | # | |
8 | # (Except where explicitly superseded by other copyright notices) | |
9 | # | |
10 | # | |
11 | # LICENSE: | |
12 | # | |
13 | # This work is made available to you under the terms of Version 2 of | |
14 | # the GNU General Public License. A copy of that license should have | |
15 | # been provided with this software, but in any event can be snarfed | |
16 | # from www.gnu.org. | |
17 | # | |
18 | # This work is distributed in the hope that it will be useful, but | |
19 | # WITHOUT ANY WARRANTY; without even the implied warranty of | |
20 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
21 | # General Public License for more details. | |
22 | # | |
23 | # You should have received a copy of the GNU General Public License | |
24 | # along with this program; if not, write to the Free Software | |
25 | # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA | |
26 | # 02110-1301 or visit their web page on the internet at | |
27 | # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html. | |
28 | # | |
29 | # | |
30 | # CONTRIBUTION SUBMISSION POLICY: | |
31 | # | |
32 | # (The following paragraph is not intended to limit the rights granted | |
33 | # to you to modify and distribute this software under the terms of | |
34 | # the GNU General Public License and is only of importance to you if | |
35 | # you choose to contribute your changes and enhancements to the | |
36 | # community by submitting them to Best Practical Solutions, LLC.) | |
37 | # | |
38 | # By intentionally submitting any modifications, corrections or | |
39 | # derivatives to this work, or any other work intended for use with | |
40 | # Request Tracker, to Best Practical Solutions, LLC, you confirm that | |
41 | # you are the copyright holder for those contributions and you grant | |
42 | # Best Practical Solutions, LLC a nonexclusive, worldwide, irrevocable, | |
43 | # royalty-free, perpetual, license to use, copy, create derivative | |
44 | # works based on those contributions, and sublicense and distribute | |
45 | # those contributions and any derivatives thereof. | |
46 | # | |
47 | # END BPS TAGGED BLOCK }}} | |
48 | ||
49 | ## Portions Copyright 2000 Tobias Brox <tobix@fsck.com> | |
50 | ||
51 | ## This is a library of static subs to be used by the Mason web | |
52 | ## interface to RT | |
53 | ||
54 | =head1 NAME | |
55 | ||
56 | RT::Interface::Web | |
57 | ||
58 | ||
59 | =cut | |
60 | ||
61 | use strict; | |
62 | use warnings; | |
63 | ||
64 | package RT::Interface::Web; | |
65 | ||
66 | use RT::SavedSearches; | |
67 | use URI qw(); | |
68 | use RT::Interface::Web::Menu; | |
69 | use RT::Interface::Web::Session; | |
70 | use Digest::MD5 (); | |
71 | use Encode qw(); | |
72 | use List::MoreUtils qw(); | |
73 | use JSON qw(); | |
74 | ||
75 | =head2 SquishedCSS $style | |
76 | ||
77 | =cut | |
78 | ||
79 | my %SQUISHED_CSS; | |
80 | sub SquishedCSS { | |
81 | my $style = shift or die "need name"; | |
82 | return $SQUISHED_CSS{$style} if $SQUISHED_CSS{$style}; | |
83 | require RT::Squish::CSS; | |
84 | my $css = RT::Squish::CSS->new( Style => $style ); | |
85 | $SQUISHED_CSS{ $css->Style } = $css; | |
86 | return $css; | |
87 | } | |
88 | ||
89 | =head2 SquishedJS | |
90 | ||
91 | =cut | |
92 | ||
93 | my $SQUISHED_JS; | |
94 | sub SquishedJS { | |
95 | return $SQUISHED_JS if $SQUISHED_JS; | |
96 | ||
97 | require RT::Squish::JS; | |
98 | my $js = RT::Squish::JS->new(); | |
99 | $SQUISHED_JS = $js; | |
100 | return $js; | |
101 | } | |
102 | ||
103 | =head2 ClearSquished | |
104 | ||
105 | Removes the cached CSS and JS entries, forcing them to be regenerated | |
106 | on next use. | |
107 | ||
108 | =cut | |
109 | ||
110 | sub ClearSquished { | |
111 | undef $SQUISHED_JS; | |
112 | %SQUISHED_CSS = (); | |
113 | } | |
114 | ||
115 | =head2 EscapeUTF8 SCALARREF | |
116 | ||
117 | does a css-busting but minimalist escaping of whatever html you're passing in. | |
118 | ||
119 | =cut | |
120 | ||
121 | sub EscapeUTF8 { | |
122 | my $ref = shift; | |
123 | return unless defined $$ref; | |
124 | ||
125 | $$ref =~ s/&/&/g; | |
126 | $$ref =~ s/</</g; | |
127 | $$ref =~ s/>/>/g; | |
128 | $$ref =~ s/\(/(/g; | |
129 | $$ref =~ s/\)/)/g; | |
130 | $$ref =~ s/"/"/g; | |
131 | $$ref =~ s/'/'/g; | |
132 | } | |
133 | ||
134 | ||
135 | ||
136 | =head2 EscapeURI SCALARREF | |
137 | ||
138 | Escapes URI component according to RFC2396 | |
139 | ||
140 | =cut | |
141 | ||
142 | sub EscapeURI { | |
143 | my $ref = shift; | |
144 | return unless defined $$ref; | |
145 | ||
146 | use bytes; | |
147 | $$ref =~ s/([^a-zA-Z0-9_.!~*'()-])/uc sprintf("%%%02X", ord($1))/eg; | |
148 | } | |
149 | ||
150 | =head2 EncodeJSON SCALAR | |
151 | ||
152 | Encodes the SCALAR to JSON and returns a JSON string. SCALAR may be a simple | |
153 | value or a reference. | |
154 | ||
155 | =cut | |
156 | ||
157 | sub EncodeJSON { | |
158 | JSON::to_json(shift, { utf8 => 1, allow_nonref => 1 }); | |
159 | } | |
160 | ||
161 | sub _encode_surrogates { | |
162 | my $uni = $_[0] - 0x10000; | |
163 | return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); | |
164 | } | |
165 | ||
166 | sub EscapeJS { | |
167 | my $ref = shift; | |
168 | return unless defined $$ref; | |
169 | ||
170 | $$ref = "'" . join('', | |
171 | map { | |
172 | chr($_) =~ /[a-zA-Z0-9]/ ? chr($_) : | |
173 | $_ <= 255 ? sprintf("\\x%02X", $_) : | |
174 | $_ <= 65535 ? sprintf("\\u%04X", $_) : | |
175 | sprintf("\\u%X\\u%X", _encode_surrogates($_)) | |
176 | } unpack('U*', $$ref)) | |
177 | . "'"; | |
178 | } | |
179 | ||
180 | =head2 WebCanonicalizeInfo(); | |
181 | ||
182 | Different web servers set different environmental varibles. This | |
183 | function must return something suitable for REMOTE_USER. By default, | |
184 | just downcase $ENV{'REMOTE_USER'} | |
185 | ||
186 | =cut | |
187 | ||
188 | sub WebCanonicalizeInfo { | |
189 | return $ENV{'REMOTE_USER'} ? lc $ENV{'REMOTE_USER'} : $ENV{'REMOTE_USER'}; | |
190 | } | |
191 | ||
192 | ||
193 | ||
194 | =head2 WebExternalAutoInfo($user); | |
195 | ||
196 | Returns a hash of user attributes, used when WebExternalAuto is set. | |
197 | ||
198 | =cut | |
199 | ||
200 | sub WebExternalAutoInfo { | |
201 | my $user = shift; | |
202 | ||
203 | my %user_info; | |
204 | ||
205 | # default to making Privileged users, even if they specify | |
206 | # some other default Attributes | |
207 | if ( !$RT::AutoCreate | |
208 | || ( ref($RT::AutoCreate) && not exists $RT::AutoCreate->{Privileged} ) ) | |
209 | { | |
210 | $user_info{'Privileged'} = 1; | |
211 | } | |
212 | ||
213 | if ( $^O !~ /^(?:riscos|MacOS|MSWin32|dos|os2)$/ ) { | |
214 | ||
215 | # Populate fields with information from Unix /etc/passwd | |
216 | ||
217 | my ( $comments, $realname ) = ( getpwnam($user) )[ 5, 6 ]; | |
218 | $user_info{'Comments'} = $comments if defined $comments; | |
219 | $user_info{'RealName'} = $realname if defined $realname; | |
220 | } elsif ( $^O eq 'MSWin32' and eval 'use Net::AdminMisc; 1' ) { | |
221 | ||
222 | # Populate fields with information from NT domain controller | |
223 | } | |
224 | ||
225 | # and return the wad of stuff | |
226 | return {%user_info}; | |
227 | } | |
228 | ||
229 | ||
230 | sub HandleRequest { | |
231 | my $ARGS = shift; | |
232 | ||
233 | if (RT->Config->Get('DevelMode')) { | |
234 | require Module::Refresh; | |
235 | Module::Refresh->refresh; | |
236 | } | |
237 | ||
238 | $HTML::Mason::Commands::r->content_type("text/html; charset=utf-8"); | |
239 | ||
240 | $HTML::Mason::Commands::m->{'rt_base_time'} = [ Time::HiRes::gettimeofday() ]; | |
241 | ||
242 | # Roll back any dangling transactions from a previous failed connection | |
243 | $RT::Handle->ForceRollback() if $RT::Handle and $RT::Handle->TransactionDepth; | |
244 | ||
245 | MaybeEnableSQLStatementLog(); | |
246 | ||
247 | # avoid reentrancy, as suggested by masonbook | |
248 | local *HTML::Mason::Commands::session unless $HTML::Mason::Commands::m->is_subrequest; | |
249 | ||
250 | $HTML::Mason::Commands::m->autoflush( $HTML::Mason::Commands::m->request_comp->attr('AutoFlush') ) | |
251 | if ( $HTML::Mason::Commands::m->request_comp->attr_exists('AutoFlush') ); | |
252 | ||
253 | ValidateWebConfig(); | |
254 | ||
255 | DecodeARGS($ARGS); | |
b5747ff2 | 256 | local $HTML::Mason::Commands::DECODED_ARGS = $ARGS; |
84fb5b46 MKG |
257 | PreprocessTimeUpdates($ARGS); |
258 | ||
259 | InitializeMenu(); | |
260 | MaybeShowInstallModePage(); | |
261 | ||
262 | $HTML::Mason::Commands::m->comp( '/Elements/SetupSessionCookie', %$ARGS ); | |
263 | SendSessionCookie(); | |
86404187 MKG |
264 | |
265 | if ( _UserLoggedIn() ) { | |
266 | # make user info up to date | |
267 | $HTML::Mason::Commands::session{'CurrentUser'} | |
268 | ->Load( $HTML::Mason::Commands::session{'CurrentUser'}->id ); | |
269 | } | |
270 | else { | |
271 | $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); | |
272 | } | |
84fb5b46 MKG |
273 | |
274 | # Process session-related callbacks before any auth attempts | |
275 | $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Session', CallbackPage => '/autohandler' ); | |
276 | ||
277 | MaybeRejectPrivateComponentRequest(); | |
278 | ||
279 | MaybeShowNoAuthPage($ARGS); | |
280 | ||
281 | AttemptExternalAuth($ARGS) if RT->Config->Get('WebExternalAuthContinuous') or not _UserLoggedIn(); | |
282 | ||
283 | _ForceLogout() unless _UserLoggedIn(); | |
284 | ||
285 | # Process per-page authentication callbacks | |
286 | $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Auth', CallbackPage => '/autohandler' ); | |
287 | ||
288 | unless ( _UserLoggedIn() ) { | |
289 | _ForceLogout(); | |
290 | ||
291 | # Authenticate if the user is trying to login via user/pass query args | |
292 | my ($authed, $msg) = AttemptPasswordAuthentication($ARGS); | |
293 | ||
294 | unless ($authed) { | |
295 | my $m = $HTML::Mason::Commands::m; | |
296 | ||
297 | # REST urls get a special 401 response | |
86404187 | 298 | if ($m->request_comp->path =~ m{^/REST/\d+\.\d+/}) { |
84fb5b46 MKG |
299 | $HTML::Mason::Commands::r->content_type("text/plain"); |
300 | $m->error_format("text"); | |
301 | $m->out("RT/$RT::VERSION 401 Credentials required\n"); | |
302 | $m->out("\n$msg\n") if $msg; | |
303 | $m->abort; | |
304 | } | |
305 | # Specially handle /index.html so that we get a nicer URL | |
306 | elsif ( $m->request_comp->path eq '/index.html' ) { | |
86404187 | 307 | my $next = SetNextPage($ARGS); |
84fb5b46 MKG |
308 | $m->comp('/NoAuth/Login.html', next => $next, actions => [$msg]); |
309 | $m->abort; | |
310 | } | |
311 | else { | |
86404187 | 312 | TangentForLogin($ARGS, results => ($msg ? LoginError($msg) : undef)); |
84fb5b46 MKG |
313 | } |
314 | } | |
315 | } | |
316 | ||
317 | MaybeShowInterstitialCSRFPage($ARGS); | |
318 | ||
319 | # now it applies not only to home page, but any dashboard that can be used as a workspace | |
320 | $HTML::Mason::Commands::session{'home_refresh_interval'} = $ARGS->{'HomeRefreshInterval'} | |
321 | if ( $ARGS->{'HomeRefreshInterval'} ); | |
322 | ||
323 | # Process per-page global callbacks | |
324 | $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Default', CallbackPage => '/autohandler' ); | |
325 | ||
326 | ShowRequestedPage($ARGS); | |
327 | LogRecordedSQLStatements(RequestData => { | |
328 | Path => $HTML::Mason::Commands::m->request_comp->path, | |
329 | }); | |
330 | ||
331 | # Process per-page final cleanup callbacks | |
332 | $HTML::Mason::Commands::m->callback( %$ARGS, CallbackName => 'Final', CallbackPage => '/autohandler' ); | |
333 | ||
334 | $HTML::Mason::Commands::m->comp( '/Elements/Footer', %$ARGS ); | |
335 | } | |
336 | ||
337 | sub _ForceLogout { | |
338 | ||
339 | delete $HTML::Mason::Commands::session{'CurrentUser'}; | |
340 | } | |
341 | ||
342 | sub _UserLoggedIn { | |
343 | if ( $HTML::Mason::Commands::session{CurrentUser} && $HTML::Mason::Commands::session{'CurrentUser'}->id ) { | |
344 | return 1; | |
345 | } else { | |
346 | return undef; | |
347 | } | |
348 | ||
349 | } | |
350 | ||
351 | =head2 LoginError ERROR | |
352 | ||
353 | Pushes a login error into the Actions session store and returns the hash key. | |
354 | ||
355 | =cut | |
356 | ||
357 | sub LoginError { | |
358 | my $new = shift; | |
359 | my $key = Digest::MD5::md5_hex( rand(1024) ); | |
360 | push @{ $HTML::Mason::Commands::session{"Actions"}->{$key} ||= [] }, $new; | |
361 | $HTML::Mason::Commands::session{'i'}++; | |
362 | return $key; | |
363 | } | |
364 | ||
86404187 | 365 | =head2 SetNextPage ARGSRef [PATH] |
84fb5b46 MKG |
366 | |
367 | Intuits and stashes the next page in the sesssion hash. If PATH is | |
368 | specified, uses that instead of the value of L<IntuitNextPage()>. Returns | |
369 | the hash value. | |
370 | ||
371 | =cut | |
372 | ||
373 | sub SetNextPage { | |
86404187 MKG |
374 | my $ARGS = shift; |
375 | my $next = $_[0] ? $_[0] : IntuitNextPage(); | |
84fb5b46 | 376 | my $hash = Digest::MD5::md5_hex($next . $$ . rand(1024)); |
86404187 MKG |
377 | my $page = { url => $next }; |
378 | ||
379 | # If an explicit URL was passed and we didn't IntuitNextPage, then | |
380 | # IsPossibleCSRF below is almost certainly unrelated to the actual | |
381 | # destination. Currently explicit next pages aren't used in RT, but the | |
382 | # API is available. | |
383 | if (not $_[0] and RT->Config->Get("RestrictReferrer")) { | |
384 | # This isn't really CSRF, but the CSRF heuristics are useful for catching | |
385 | # requests which may have unintended side-effects. | |
386 | my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); | |
387 | if ($is_csrf) { | |
388 | RT->Logger->notice( | |
389 | "Marking original destination as having side-effects before redirecting for login.\n" | |
390 | ."Request: $next\n" | |
391 | ."Reason: " . HTML::Mason::Commands::loc($msg, @loc) | |
392 | ); | |
393 | $page->{'HasSideEffects'} = [$msg, @loc]; | |
394 | } | |
395 | } | |
84fb5b46 | 396 | |
86404187 | 397 | $HTML::Mason::Commands::session{'NextPage'}->{$hash} = $page; |
84fb5b46 MKG |
398 | $HTML::Mason::Commands::session{'i'}++; |
399 | return $hash; | |
400 | } | |
401 | ||
86404187 MKG |
402 | =head2 FetchNextPage HASHKEY |
403 | ||
404 | Returns the stashed next page hashref for the given hash. | |
405 | ||
406 | =cut | |
407 | ||
408 | sub FetchNextPage { | |
409 | my $hash = shift || ""; | |
410 | return $HTML::Mason::Commands::session{'NextPage'}->{$hash}; | |
411 | } | |
412 | ||
413 | =head2 RemoveNextPage HASHKEY | |
414 | ||
415 | Removes the stashed next page for the given hash and returns it. | |
416 | ||
417 | =cut | |
418 | ||
419 | sub RemoveNextPage { | |
420 | my $hash = shift || ""; | |
421 | return delete $HTML::Mason::Commands::session{'NextPage'}->{$hash}; | |
422 | } | |
84fb5b46 | 423 | |
86404187 | 424 | =head2 TangentForLogin ARGSRef [HASH] |
84fb5b46 MKG |
425 | |
426 | Redirects to C</NoAuth/Login.html>, setting the value of L<IntuitNextPage> as | |
86404187 MKG |
427 | the next page. Takes a hashref of request %ARGS as the first parameter. |
428 | Optionally takes all other parameters as a hash which is dumped into query | |
429 | params. | |
84fb5b46 MKG |
430 | |
431 | =cut | |
432 | ||
433 | sub TangentForLogin { | |
86404187 MKG |
434 | my $ARGS = shift; |
435 | my $hash = SetNextPage($ARGS); | |
84fb5b46 MKG |
436 | my %query = (@_, next => $hash); |
437 | my $login = RT->Config->Get('WebURL') . 'NoAuth/Login.html?'; | |
438 | $login .= $HTML::Mason::Commands::m->comp('/Elements/QueryString', %query); | |
439 | Redirect($login); | |
440 | } | |
441 | ||
442 | =head2 TangentForLoginWithError ERROR | |
443 | ||
444 | Localizes the passed error message, stashes it with L<LoginError> and then | |
445 | calls L<TangentForLogin> with the appropriate results key. | |
446 | ||
447 | =cut | |
448 | ||
449 | sub TangentForLoginWithError { | |
86404187 MKG |
450 | my $ARGS = shift; |
451 | my $key = LoginError(HTML::Mason::Commands::loc(@_)); | |
452 | TangentForLogin( $ARGS, results => $key ); | |
84fb5b46 MKG |
453 | } |
454 | ||
455 | =head2 IntuitNextPage | |
456 | ||
457 | Attempt to figure out the path to which we should return the user after a | |
458 | tangent. The current request URL is used, or failing that, the C<WebURL> | |
459 | configuration variable. | |
460 | ||
461 | =cut | |
462 | ||
463 | sub IntuitNextPage { | |
464 | my $req_uri; | |
465 | ||
466 | # This includes any query parameters. Redirect will take care of making | |
467 | # it an absolute URL. | |
468 | if ($ENV{'REQUEST_URI'}) { | |
469 | $req_uri = $ENV{'REQUEST_URI'}; | |
470 | ||
471 | # collapse multiple leading slashes so the first part doesn't look like | |
472 | # a hostname of a schema-less URI | |
473 | $req_uri =~ s{^/+}{/}; | |
474 | } | |
475 | ||
476 | my $next = defined $req_uri ? $req_uri : RT->Config->Get('WebURL'); | |
477 | ||
478 | # sanitize $next | |
479 | my $uri = URI->new($next); | |
480 | ||
481 | # You get undef scheme with a relative uri like "/Search/Build.html" | |
482 | unless (!defined($uri->scheme) || $uri->scheme eq 'http' || $uri->scheme eq 'https') { | |
483 | $next = RT->Config->Get('WebURL'); | |
484 | } | |
485 | ||
486 | # Make sure we're logging in to the same domain | |
487 | # You can get an undef authority with a relative uri like "index.html" | |
488 | my $uri_base_url = URI->new(RT->Config->Get('WebBaseURL')); | |
489 | unless (!defined($uri->authority) || $uri->authority eq $uri_base_url->authority) { | |
490 | $next = RT->Config->Get('WebURL'); | |
491 | } | |
492 | ||
493 | return $next; | |
494 | } | |
495 | ||
496 | =head2 MaybeShowInstallModePage | |
497 | ||
498 | This function, called exclusively by RT's autohandler, dispatches | |
499 | a request to RT's Installation workflow, only if Install Mode is enabled in the configuration file. | |
500 | ||
501 | If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler | |
502 | ||
503 | =cut | |
504 | ||
505 | sub MaybeShowInstallModePage { | |
506 | return unless RT->InstallMode; | |
507 | ||
508 | my $m = $HTML::Mason::Commands::m; | |
509 | if ( $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex') ) { | |
510 | $m->call_next(); | |
86404187 | 511 | } elsif ( $m->request_comp->path !~ m{^(/+)Install/} ) { |
84fb5b46 MKG |
512 | RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "Install/index.html" ); |
513 | } else { | |
514 | $m->call_next(); | |
515 | } | |
516 | $m->abort(); | |
517 | } | |
518 | ||
519 | =head2 MaybeShowNoAuthPage \%ARGS | |
520 | ||
521 | This function, called exclusively by RT's autohandler, dispatches | |
522 | a request to the page a user requested (but only if it matches the "noauth" regex. | |
523 | ||
524 | If it serves a page, it stops mason processing. Otherwise, mason just keeps running through the autohandler | |
525 | ||
526 | =cut | |
527 | ||
528 | sub MaybeShowNoAuthPage { | |
529 | my $ARGS = shift; | |
530 | ||
531 | my $m = $HTML::Mason::Commands::m; | |
532 | ||
533 | return unless $m->base_comp->path =~ RT->Config->Get('WebNoAuthRegex'); | |
534 | ||
535 | # Don't show the login page to logged in users | |
536 | Redirect(RT->Config->Get('WebURL')) | |
537 | if $m->base_comp->path eq '/NoAuth/Login.html' and _UserLoggedIn(); | |
538 | ||
539 | # If it's a noauth file, don't ask for auth. | |
540 | $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); | |
541 | $m->abort; | |
542 | } | |
543 | ||
544 | =head2 MaybeRejectPrivateComponentRequest | |
545 | ||
546 | This function will reject calls to private components, like those under | |
547 | C</Elements>. If the requested path is a private component then we will | |
548 | abort with a C<403> error. | |
549 | ||
550 | =cut | |
551 | ||
552 | sub MaybeRejectPrivateComponentRequest { | |
553 | my $m = $HTML::Mason::Commands::m; | |
554 | my $path = $m->request_comp->path; | |
555 | ||
556 | # We do not check for dhandler here, because requesting our dhandlers | |
557 | # directly is okay. Mason will invoke the dhandler with a dhandler_arg of | |
558 | # 'dhandler'. | |
559 | ||
560 | if ($path =~ m{ | |
561 | / # leading slash | |
562 | ( Elements | | |
563 | _elements | # mobile UI | |
564 | Widgets | | |
565 | autohandler | # requesting this directly is suspicious | |
566 | l (_unsafe)? ) # loc component | |
567 | ( $ | / ) # trailing slash or end of path | |
568 | }xi) { | |
569 | $m->abort(403); | |
570 | } | |
571 | ||
572 | return; | |
573 | } | |
574 | ||
575 | sub InitializeMenu { | |
576 | $HTML::Mason::Commands::m->notes('menu', RT::Interface::Web::Menu->new()); | |
577 | $HTML::Mason::Commands::m->notes('page-menu', RT::Interface::Web::Menu->new()); | |
578 | $HTML::Mason::Commands::m->notes('page-widgets', RT::Interface::Web::Menu->new()); | |
579 | ||
580 | } | |
581 | ||
582 | ||
583 | =head2 ShowRequestedPage \%ARGS | |
584 | ||
585 | This function, called exclusively by RT's autohandler, dispatches | |
586 | a request to the page a user requested (making sure that unpriviled users | |
587 | can only see self-service pages. | |
588 | ||
589 | =cut | |
590 | ||
591 | sub ShowRequestedPage { | |
592 | my $ARGS = shift; | |
593 | ||
594 | my $m = $HTML::Mason::Commands::m; | |
595 | ||
b5747ff2 MKG |
596 | # Ensure that the cookie that we send is up-to-date, in case the |
597 | # session-id has been modified in any way | |
598 | SendSessionCookie(); | |
599 | ||
84fb5b46 MKG |
600 | # precache all system level rights for the current user |
601 | $HTML::Mason::Commands::session{CurrentUser}->PrincipalObj->HasRights( Object => RT->System ); | |
602 | ||
603 | # If the user isn't privileged, they can only see SelfService | |
604 | unless ( $HTML::Mason::Commands::session{'CurrentUser'}->Privileged ) { | |
605 | ||
606 | # if the user is trying to access a ticket, redirect them | |
86404187 | 607 | if ( $m->request_comp->path =~ m{^(/+)Ticket/Display.html} && $ARGS->{'id'} ) { |
84fb5b46 MKG |
608 | RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/Display.html?id=" . $ARGS->{'id'} ); |
609 | } | |
610 | ||
611 | # otherwise, drop the user at the SelfService default page | |
612 | elsif ( $m->base_comp->path !~ RT->Config->Get('SelfServiceRegex') ) { | |
613 | RT::Interface::Web::Redirect( RT->Config->Get('WebURL') . "SelfService/" ); | |
614 | } | |
615 | ||
616 | # if user is in SelfService dir let him do anything | |
617 | else { | |
618 | $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); | |
619 | } | |
620 | } else { | |
621 | $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %$ARGS ); | |
622 | } | |
623 | ||
624 | } | |
625 | ||
626 | sub AttemptExternalAuth { | |
627 | my $ARGS = shift; | |
628 | ||
629 | return unless ( RT->Config->Get('WebExternalAuth') ); | |
630 | ||
631 | my $user = $ARGS->{user}; | |
632 | my $m = $HTML::Mason::Commands::m; | |
633 | ||
634 | # If RT is configured for external auth, let's go through and get REMOTE_USER | |
635 | ||
636 | # do we actually have a REMOTE_USER equivlent? | |
637 | if ( RT::Interface::Web::WebCanonicalizeInfo() ) { | |
638 | my $orig_user = $user; | |
639 | ||
640 | $user = RT::Interface::Web::WebCanonicalizeInfo(); | |
641 | my $load_method = RT->Config->Get('WebExternalGecos') ? 'LoadByGecos' : 'Load'; | |
642 | ||
643 | if ( $^O eq 'MSWin32' and RT->Config->Get('WebExternalGecos') ) { | |
644 | my $NodeName = Win32::NodeName(); | |
645 | $user =~ s/^\Q$NodeName\E\\//i; | |
646 | } | |
647 | ||
86404187 MKG |
648 | my $next = RemoveNextPage($ARGS->{'next'}); |
649 | $next = $next->{'url'} if ref $next; | |
84fb5b46 MKG |
650 | InstantiateNewSession() unless _UserLoggedIn; |
651 | $HTML::Mason::Commands::session{'CurrentUser'} = RT::CurrentUser->new(); | |
652 | $HTML::Mason::Commands::session{'CurrentUser'}->$load_method($user); | |
653 | ||
654 | if ( RT->Config->Get('WebExternalAuto') and not _UserLoggedIn() ) { | |
655 | ||
656 | # Create users on-the-fly | |
657 | my $UserObj = RT::User->new(RT->SystemUser); | |
658 | my ( $val, $msg ) = $UserObj->Create( | |
659 | %{ ref RT->Config->Get('AutoCreate') ? RT->Config->Get('AutoCreate') : {} }, | |
660 | Name => $user, | |
661 | Gecos => $user, | |
662 | ); | |
663 | ||
664 | if ($val) { | |
665 | ||
666 | # now get user specific information, to better create our user. | |
667 | my $new_user_info = RT::Interface::Web::WebExternalAutoInfo($user); | |
668 | ||
669 | # set the attributes that have been defined. | |
670 | foreach my $attribute ( $UserObj->WritableAttributes ) { | |
671 | $m->callback( | |
672 | Attribute => $attribute, | |
673 | User => $user, | |
674 | UserInfo => $new_user_info, | |
675 | CallbackName => 'NewUser', | |
676 | CallbackPage => '/autohandler' | |
677 | ); | |
678 | my $method = "Set$attribute"; | |
679 | $UserObj->$method( $new_user_info->{$attribute} ) if defined $new_user_info->{$attribute}; | |
680 | } | |
681 | $HTML::Mason::Commands::session{'CurrentUser'}->Load($user); | |
682 | } else { | |
683 | ||
684 | # we failed to successfully create the user. abort abort abort. | |
685 | delete $HTML::Mason::Commands::session{'CurrentUser'}; | |
686 | ||
687 | if (RT->Config->Get('WebFallbackToInternalAuth')) { | |
86404187 | 688 | TangentForLoginWithError($ARGS, 'Cannot create user: [_1]', $msg); |
84fb5b46 MKG |
689 | } else { |
690 | $m->abort(); | |
691 | } | |
692 | } | |
693 | } | |
694 | ||
695 | if ( _UserLoggedIn() ) { | |
696 | $m->callback( %$ARGS, CallbackName => 'ExternalAuthSuccessfulLogin', CallbackPage => '/autohandler' ); | |
697 | # It is possible that we did a redirect to the login page, | |
698 | # if the external auth allows lack of auth through with no | |
699 | # REMOTE_USER set, instead of forcing a "permission | |
700 | # denied" message. Honor the $next. | |
701 | Redirect($next) if $next; | |
702 | # Unlike AttemptPasswordAuthentication below, we do not | |
703 | # force a redirect to / if $next is not set -- otherwise, | |
704 | # straight-up external auth would always redirect to / | |
705 | # when you first hit it. | |
706 | } else { | |
707 | delete $HTML::Mason::Commands::session{'CurrentUser'}; | |
708 | $user = $orig_user; | |
709 | ||
86404187 MKG |
710 | unless ( RT->Config->Get('WebFallbackToInternalAuth') ) { |
711 | TangentForLoginWithError($ARGS, 'You are not an authorized user'); | |
84fb5b46 MKG |
712 | } |
713 | } | |
714 | } elsif ( RT->Config->Get('WebFallbackToInternalAuth') ) { | |
715 | unless ( defined $HTML::Mason::Commands::session{'CurrentUser'} ) { | |
716 | # XXX unreachable due to prior defaulting in HandleRequest (check c34d108) | |
86404187 | 717 | TangentForLoginWithError($ARGS, 'You are not an authorized user'); |
84fb5b46 MKG |
718 | } |
719 | } else { | |
720 | ||
721 | # WebExternalAuth is set, but we don't have a REMOTE_USER. abort | |
722 | # XXX: we must return AUTH_REQUIRED status or we fallback to | |
723 | # internal auth here too. | |
724 | delete $HTML::Mason::Commands::session{'CurrentUser'} | |
725 | if defined $HTML::Mason::Commands::session{'CurrentUser'}; | |
726 | } | |
727 | } | |
728 | ||
729 | sub AttemptPasswordAuthentication { | |
730 | my $ARGS = shift; | |
731 | return unless defined $ARGS->{user} && defined $ARGS->{pass}; | |
732 | ||
733 | my $user_obj = RT::CurrentUser->new(); | |
734 | $user_obj->Load( $ARGS->{user} ); | |
735 | ||
736 | my $m = $HTML::Mason::Commands::m; | |
737 | ||
738 | unless ( $user_obj->id && $user_obj->IsPassword( $ARGS->{pass} ) ) { | |
739 | $RT::Logger->error("FAILED LOGIN for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}"); | |
740 | $m->callback( %$ARGS, CallbackName => 'FailedLogin', CallbackPage => '/autohandler' ); | |
741 | return (0, HTML::Mason::Commands::loc('Your username or password is incorrect')); | |
742 | } | |
743 | else { | |
744 | $RT::Logger->info("Successful login for @{[$ARGS->{user}]} from $ENV{'REMOTE_ADDR'}"); | |
745 | ||
746 | # It's important to nab the next page from the session before we blow | |
747 | # the session away | |
86404187 MKG |
748 | my $next = RemoveNextPage($ARGS->{'next'}); |
749 | $next = $next->{'url'} if ref $next; | |
84fb5b46 MKG |
750 | |
751 | InstantiateNewSession(); | |
752 | $HTML::Mason::Commands::session{'CurrentUser'} = $user_obj; | |
84fb5b46 MKG |
753 | |
754 | $m->callback( %$ARGS, CallbackName => 'SuccessfulLogin', CallbackPage => '/autohandler' ); | |
755 | ||
756 | # Really the only time we don't want to redirect here is if we were | |
757 | # passed user and pass as query params in the URL. | |
758 | if ($next) { | |
759 | Redirect($next); | |
760 | } | |
761 | elsif ($ARGS->{'next'}) { | |
762 | # Invalid hash, but still wants to go somewhere, take them to / | |
763 | Redirect(RT->Config->Get('WebURL')); | |
764 | } | |
765 | ||
766 | return (1, HTML::Mason::Commands::loc('Logged in')); | |
767 | } | |
768 | } | |
769 | ||
770 | =head2 LoadSessionFromCookie | |
771 | ||
772 | Load or setup a session cookie for the current user. | |
773 | ||
774 | =cut | |
775 | ||
776 | sub _SessionCookieName { | |
777 | my $cookiename = "RT_SID_" . RT->Config->Get('rtname'); | |
778 | $cookiename .= "." . $ENV{'SERVER_PORT'} if $ENV{'SERVER_PORT'}; | |
779 | return $cookiename; | |
780 | } | |
781 | ||
782 | sub LoadSessionFromCookie { | |
783 | ||
784 | my %cookies = CGI::Cookie->fetch; | |
785 | my $cookiename = _SessionCookieName(); | |
786 | my $SessionCookie = ( $cookies{$cookiename} ? $cookies{$cookiename}->value : undef ); | |
787 | tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', $SessionCookie; | |
788 | unless ( $SessionCookie && $HTML::Mason::Commands::session{'_session_id'} eq $SessionCookie ) { | |
789 | undef $cookies{$cookiename}; | |
790 | } | |
791 | if ( int RT->Config->Get('AutoLogoff') ) { | |
792 | my $now = int( time / 60 ); | |
793 | my $last_update = $HTML::Mason::Commands::session{'_session_last_update'} || 0; | |
794 | ||
795 | if ( $last_update && ( $now - $last_update - RT->Config->Get('AutoLogoff') ) > 0 ) { | |
796 | InstantiateNewSession(); | |
797 | } | |
798 | ||
799 | # save session on each request when AutoLogoff is turned on | |
800 | $HTML::Mason::Commands::session{'_session_last_update'} = $now if $now != $last_update; | |
801 | } | |
802 | } | |
803 | ||
804 | sub InstantiateNewSession { | |
805 | tied(%HTML::Mason::Commands::session)->delete if tied(%HTML::Mason::Commands::session); | |
806 | tie %HTML::Mason::Commands::session, 'RT::Interface::Web::Session', undef; | |
b5747ff2 | 807 | SendSessionCookie(); |
84fb5b46 MKG |
808 | } |
809 | ||
810 | sub SendSessionCookie { | |
811 | my $cookie = CGI::Cookie->new( | |
812 | -name => _SessionCookieName(), | |
813 | -value => $HTML::Mason::Commands::session{_session_id}, | |
814 | -path => RT->Config->Get('WebPath'), | |
815 | -secure => ( RT->Config->Get('WebSecureCookies') ? 1 : 0 ), | |
816 | -httponly => ( RT->Config->Get('WebHttpOnlyCookies') ? 1 : 0 ), | |
817 | ); | |
818 | ||
819 | $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'} = $cookie->as_string; | |
820 | } | |
821 | ||
822 | =head2 Redirect URL | |
823 | ||
824 | This routine ells the current user's browser to redirect to URL. | |
825 | Additionally, it unties the user's currently active session, helping to avoid | |
826 | A bug in Apache::Session 1.81 and earlier which clobbers sessions if we try to use | |
827 | a cached DBI statement handle twice at the same time. | |
828 | ||
829 | =cut | |
830 | ||
831 | sub Redirect { | |
832 | my $redir_to = shift; | |
833 | untie $HTML::Mason::Commands::session; | |
834 | my $uri = URI->new($redir_to); | |
835 | my $server_uri = URI->new( RT->Config->Get('WebURL') ); | |
836 | ||
837 | # Make relative URIs absolute from the server host and scheme | |
838 | $uri->scheme($server_uri->scheme) if not defined $uri->scheme; | |
839 | if (not defined $uri->host) { | |
840 | $uri->host($server_uri->host); | |
841 | $uri->port($server_uri->port); | |
842 | } | |
843 | ||
844 | # If the user is coming in via a non-canonical | |
845 | # hostname, don't redirect them to the canonical host, | |
846 | # it will just upset them (and invalidate their credentials) | |
847 | # don't do this if $RT::CanonicalizeRedirectURLs is true | |
848 | if ( !RT->Config->Get('CanonicalizeRedirectURLs') | |
849 | && $uri->host eq $server_uri->host | |
850 | && $uri->port eq $server_uri->port ) | |
851 | { | |
852 | if ( defined $ENV{HTTPS} and $ENV{'HTTPS'} eq 'on' ) { | |
853 | $uri->scheme('https'); | |
854 | } else { | |
855 | $uri->scheme('http'); | |
856 | } | |
857 | ||
858 | # [rt3.fsck.com #12716] Apache recommends use of $SERVER_HOST | |
859 | $uri->host( $ENV{'SERVER_HOST'} || $ENV{'HTTP_HOST'} || $ENV{'SERVER_NAME'}); | |
860 | $uri->port( $ENV{'SERVER_PORT'} ); | |
861 | } | |
862 | ||
863 | # not sure why, but on some systems without this call mason doesn't | |
864 | # set status to 302, but 200 instead and people see blank pages | |
865 | $HTML::Mason::Commands::r->status(302); | |
866 | ||
867 | # Perlbal expects a status message, but Mason's default redirect status | |
868 | # doesn't provide one. See also rt.cpan.org #36689. | |
869 | $HTML::Mason::Commands::m->redirect( $uri->canonical, "302 Found" ); | |
870 | ||
871 | $HTML::Mason::Commands::m->abort; | |
872 | } | |
873 | ||
874 | =head2 StaticFileHeaders | |
875 | ||
876 | Send the browser a few headers to try to get it to (somewhat agressively) | |
877 | cache RT's static Javascript and CSS files. | |
878 | ||
879 | This routine could really use _accurate_ heuristics. (XXX TODO) | |
880 | ||
881 | =cut | |
882 | ||
883 | sub StaticFileHeaders { | |
884 | my $date = RT::Date->new(RT->SystemUser); | |
885 | ||
886 | # make cache public | |
887 | $HTML::Mason::Commands::r->headers_out->{'Cache-Control'} = 'max-age=259200, public'; | |
888 | ||
889 | # remove any cookie headers -- if it is cached publicly, it | |
890 | # shouldn't include anyone's cookie! | |
891 | delete $HTML::Mason::Commands::r->err_headers_out->{'Set-Cookie'}; | |
892 | ||
893 | # Expire things in a month. | |
894 | $date->Set( Value => time + 30 * 24 * 60 * 60 ); | |
895 | $HTML::Mason::Commands::r->headers_out->{'Expires'} = $date->RFC2616; | |
896 | ||
897 | # if we set 'Last-Modified' then browser request a comp using 'If-Modified-Since' | |
898 | # request, but we don't handle it and generate full reply again | |
899 | # Last modified at server start time | |
900 | # $date->Set( Value => $^T ); | |
901 | # $HTML::Mason::Commands::r->headers_out->{'Last-Modified'} = $date->RFC2616; | |
902 | } | |
903 | ||
904 | =head2 ComponentPathIsSafe PATH | |
905 | ||
906 | Takes C<PATH> and returns a boolean indicating that the user-specified partial | |
907 | component path is safe. | |
908 | ||
909 | Currently "safe" means that the path does not start with a dot (C<.>) and does | |
910 | not contain a slash-dot C</.>. | |
911 | ||
912 | =cut | |
913 | ||
914 | sub ComponentPathIsSafe { | |
915 | my $self = shift; | |
916 | my $path = shift; | |
917 | return $path !~ m{(?:^|/)\.}; | |
918 | } | |
919 | ||
920 | =head2 PathIsSafe | |
921 | ||
922 | Takes a C<< Path => path >> and returns a boolean indicating that | |
923 | the path is safely within RT's control or not. The path I<must> be | |
924 | relative. | |
925 | ||
926 | This function does not consult the filesystem at all; it is merely | |
927 | a logical sanity checking of the path. This explicitly does not handle | |
928 | symlinks; if you have symlinks in RT's webroot pointing outside of it, | |
929 | then we assume you know what you are doing. | |
930 | ||
931 | =cut | |
932 | ||
933 | sub PathIsSafe { | |
934 | my $self = shift; | |
935 | my %args = @_; | |
936 | my $path = $args{Path}; | |
937 | ||
938 | # Get File::Spec to clean up extra /s, ./, etc | |
939 | my $cleaned_up = File::Spec->canonpath($path); | |
940 | ||
941 | if (!defined($cleaned_up)) { | |
942 | $RT::Logger->info("Rejecting path that canonpath doesn't understand: $path"); | |
943 | return 0; | |
944 | } | |
945 | ||
946 | # Forbid too many ..s. We can't just sum then check because | |
947 | # "../foo/bar/baz" should be illegal even though it has more | |
948 | # downdirs than updirs. So as soon as we get a negative score | |
949 | # (which means "breaking out" of the top level) we reject the path. | |
950 | ||
951 | my @components = split '/', $cleaned_up; | |
952 | my $score = 0; | |
953 | for my $component (@components) { | |
954 | if ($component eq '..') { | |
955 | $score--; | |
956 | if ($score < 0) { | |
957 | $RT::Logger->info("Rejecting unsafe path: $path"); | |
958 | return 0; | |
959 | } | |
960 | } | |
961 | elsif ($component eq '.' || $component eq '') { | |
962 | # these two have no effect on $score | |
963 | } | |
964 | else { | |
965 | $score++; | |
966 | } | |
967 | } | |
968 | ||
969 | return 1; | |
970 | } | |
971 | ||
972 | =head2 SendStaticFile | |
973 | ||
974 | Takes a File => path and a Type => Content-type | |
975 | ||
976 | If Type isn't provided and File is an image, it will | |
977 | figure out a sane Content-type, otherwise it will | |
978 | send application/octet-stream | |
979 | ||
980 | Will set caching headers using StaticFileHeaders | |
981 | ||
982 | =cut | |
983 | ||
984 | sub SendStaticFile { | |
985 | my $self = shift; | |
986 | my %args = @_; | |
987 | my $file = $args{File}; | |
988 | my $type = $args{Type}; | |
989 | my $relfile = $args{RelativeFile}; | |
990 | ||
991 | if (defined($relfile) && !$self->PathIsSafe(Path => $relfile)) { | |
992 | $HTML::Mason::Commands::r->status(400); | |
993 | $HTML::Mason::Commands::m->abort; | |
994 | } | |
995 | ||
996 | $self->StaticFileHeaders(); | |
997 | ||
998 | unless ($type) { | |
999 | if ( $file =~ /\.(gif|png|jpe?g)$/i ) { | |
1000 | $type = "image/$1"; | |
1001 | $type =~ s/jpg/jpeg/gi; | |
1002 | } | |
1003 | $type ||= "application/octet-stream"; | |
1004 | } | |
1005 | $HTML::Mason::Commands::r->content_type($type); | |
1006 | open( my $fh, '<', $file ) or die "couldn't open file: $!"; | |
1007 | binmode($fh); | |
1008 | { | |
1009 | local $/ = \16384; | |
1010 | $HTML::Mason::Commands::m->out($_) while (<$fh>); | |
1011 | $HTML::Mason::Commands::m->flush_buffer; | |
1012 | } | |
1013 | close $fh; | |
1014 | } | |
1015 | ||
1016 | ||
1017 | ||
1018 | sub MobileClient { | |
1019 | my $self = shift; | |
1020 | ||
1021 | ||
86404187 | 1022 | if (($ENV{'HTTP_USER_AGENT'} || '') =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Mobile)/io && !$HTML::Mason::Commands::session{'NotMobile'}) { |
84fb5b46 MKG |
1023 | return 1; |
1024 | } else { | |
1025 | return undef; | |
1026 | } | |
1027 | ||
1028 | } | |
1029 | ||
1030 | ||
1031 | sub StripContent { | |
1032 | my %args = @_; | |
1033 | my $content = $args{Content}; | |
1034 | return '' unless $content; | |
1035 | ||
1036 | # Make the content have no 'weird' newlines in it | |
1037 | $content =~ s/\r+\n/\n/g; | |
1038 | ||
1039 | my $return_content = $content; | |
1040 | ||
1041 | my $html = $args{ContentType} && $args{ContentType} eq "text/html"; | |
1042 | my $sigonly = $args{StripSignature}; | |
1043 | ||
1044 | # massage content to easily detect if there's any real content | |
1045 | $content =~ s/\s+//g; # yes! remove all the spaces | |
1046 | if ( $html ) { | |
1047 | # remove html version of spaces and newlines | |
1048 | $content =~ s! !!g; | |
1049 | $content =~ s!<br/?>!!g; | |
1050 | } | |
1051 | ||
1052 | # Filter empty content when type is text/html | |
1053 | return '' if $html && $content !~ /\S/; | |
1054 | ||
1055 | # If we aren't supposed to strip the sig, just bail now. | |
1056 | return $return_content unless $sigonly; | |
1057 | ||
1058 | # Find the signature | |
1059 | my $sig = $args{'CurrentUser'}->UserObj->Signature || ''; | |
1060 | $sig =~ s/\s+//g; | |
1061 | ||
1062 | # Check for plaintext sig | |
1063 | return '' if not $html and $content =~ /^(--)?\Q$sig\E$/; | |
1064 | ||
1065 | # Check for html-formatted sig; we don't use EscapeUTF8 here | |
1066 | # because we want to precisely match the escapting that FCKEditor | |
1067 | # uses. | |
1068 | $sig =~ s/&/&/g; | |
1069 | $sig =~ s/</</g; | |
1070 | $sig =~ s/>/>/g; | |
1071 | $sig =~ s/"/"/g; | |
1072 | $sig =~ s/'/'/g; | |
1073 | return '' if $html and $content =~ m{^(?:<p>)?(--)?\Q$sig\E(?:</p>)?$}s; | |
1074 | ||
1075 | # Pass it through | |
1076 | return $return_content; | |
1077 | } | |
1078 | ||
1079 | sub DecodeARGS { | |
1080 | my $ARGS = shift; | |
1081 | ||
1082 | %{$ARGS} = map { | |
1083 | ||
1084 | # if they've passed multiple values, they'll be an array. if they've | |
1085 | # passed just one, a scalar whatever they are, mark them as utf8 | |
1086 | my $type = ref($_); | |
1087 | ( !$type ) | |
1088 | ? Encode::is_utf8($_) | |
1089 | ? $_ | |
1090 | : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) | |
1091 | : ( $type eq 'ARRAY' ) | |
1092 | ? [ map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } | |
1093 | @$_ ] | |
1094 | : ( $type eq 'HASH' ) | |
1095 | ? { map { ( ref($_) or Encode::is_utf8($_) ) ? $_ : Encode::decode( 'UTF-8' => $_, Encode::FB_PERLQQ ) } | |
1096 | %$_ } | |
1097 | : $_ | |
1098 | } %$ARGS; | |
1099 | } | |
1100 | ||
1101 | sub PreprocessTimeUpdates { | |
1102 | my $ARGS = shift; | |
1103 | ||
1104 | # Later in the code we use | |
1105 | # $m->comp( { base_comp => $m->request_comp }, $m->fetch_next, %ARGS ); | |
1106 | # instead of $m->call_next to avoid problems with UTF8 keys in arguments. | |
1107 | # The call_next method pass through original arguments and if you have | |
1108 | # an argument with unicode key then in a next component you'll get two | |
1109 | # records in the args hash: one with key without UTF8 flag and another | |
1110 | # with the flag, which may result into errors. "{ base_comp => $m->request_comp }" | |
1111 | # is copied from mason's source to get the same results as we get from | |
1112 | # call_next method, this feature is not documented, so we just leave it | |
1113 | # here to avoid possible side effects. | |
1114 | ||
1115 | # This code canonicalizes time inputs in hours into minutes | |
1116 | foreach my $field ( keys %$ARGS ) { | |
1117 | next unless $field =~ /^(.*)-TimeUnits$/i && $ARGS->{$1}; | |
1118 | my $local = $1; | |
1119 | $ARGS->{$local} =~ s{\b (?: (\d+) \s+ )? (\d+)/(\d+) \b} | |
1120 | {($1 || 0) + $3 ? $2 / $3 : 0}xe; | |
1121 | if ( $ARGS->{$field} && $ARGS->{$field} =~ /hours/i ) { | |
1122 | $ARGS->{$local} *= 60; | |
1123 | } | |
1124 | delete $ARGS->{$field}; | |
1125 | } | |
1126 | ||
1127 | } | |
1128 | ||
1129 | sub MaybeEnableSQLStatementLog { | |
1130 | ||
1131 | my $log_sql_statements = RT->Config->Get('StatementLog'); | |
1132 | ||
1133 | if ($log_sql_statements) { | |
1134 | $RT::Handle->ClearSQLStatementLog; | |
1135 | $RT::Handle->LogSQLStatements(1); | |
1136 | } | |
1137 | ||
1138 | } | |
1139 | ||
1140 | sub LogRecordedSQLStatements { | |
1141 | my %args = @_; | |
1142 | ||
1143 | my $log_sql_statements = RT->Config->Get('StatementLog'); | |
1144 | ||
1145 | return unless ($log_sql_statements); | |
1146 | ||
1147 | my @log = $RT::Handle->SQLStatementLog; | |
1148 | $RT::Handle->ClearSQLStatementLog; | |
1149 | ||
1150 | $RT::Handle->AddRequestToHistory({ | |
1151 | %{ $args{RequestData} }, | |
1152 | Queries => \@log, | |
1153 | }); | |
1154 | ||
1155 | for my $stmt (@log) { | |
1156 | my ( $time, $sql, $bind, $duration ) = @{$stmt}; | |
1157 | my @bind; | |
1158 | if ( ref $bind ) { | |
1159 | @bind = @{$bind}; | |
1160 | } else { | |
1161 | ||
1162 | # Older DBIx-SB | |
1163 | $duration = $bind; | |
1164 | } | |
1165 | $RT::Logger->log( | |
1166 | level => $log_sql_statements, | |
1167 | message => "SQL(" | |
1168 | . sprintf( "%.6f", $duration ) | |
1169 | . "s): $sql;" | |
1170 | . ( @bind ? " [ bound values: @{[map{ defined $_ ? qq|'$_'| : 'undef'} @bind]} ]" : "" ) | |
1171 | ); | |
1172 | } | |
1173 | ||
1174 | } | |
1175 | ||
1176 | my $_has_validated_web_config = 0; | |
1177 | sub ValidateWebConfig { | |
1178 | my $self = shift; | |
1179 | ||
1180 | # do this once per server instance, not once per request | |
1181 | return if $_has_validated_web_config; | |
1182 | $_has_validated_web_config = 1; | |
1183 | ||
1184 | if (!$ENV{'rt.explicit_port'} && $ENV{SERVER_PORT} != RT->Config->Get('WebPort')) { | |
1185 | $RT::Logger->warn("The actual SERVER_PORT ($ENV{SERVER_PORT}) does NOT match the configured WebPort ($RT::WebPort). Perhaps you should Set(\$WebPort, $ENV{SERVER_PORT}); in RT_SiteConfig.pm, otherwise your internal links may be broken."); | |
1186 | } | |
1187 | ||
1188 | if ($ENV{HTTP_HOST}) { | |
1189 | # match "example.com" or "example.com:80" | |
1190 | my ($host) = $ENV{HTTP_HOST} =~ /^(.*?)(:\d+)?$/; | |
1191 | ||
1192 | if ($host ne RT->Config->Get('WebDomain')) { | |
1193 | $RT::Logger->warn("The actual HTTP_HOST ($host) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$host'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); | |
1194 | } | |
1195 | } | |
1196 | else { | |
1197 | if ($ENV{SERVER_NAME} ne RT->Config->Get('WebDomain')) { | |
1198 | $RT::Logger->warn("The actual SERVER_NAME ($ENV{SERVER_NAME}) does NOT match the configured WebDomain ($RT::WebDomain). Perhaps you should Set(\$WebDomain, '$ENV{SERVER_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); | |
1199 | } | |
1200 | } | |
1201 | ||
1202 | if ($ENV{SCRIPT_NAME} ne RT->Config->Get('WebPath')) { | |
1203 | $RT::Logger->warn("The actual SCRIPT_NAME ($ENV{SCRIPT_NAME}) does NOT match the configured WebPath ($RT::WebPath). Perhaps you should Set(\$WebPath, '$ENV{SCRIPT_NAME}'); in RT_SiteConfig.pm, otherwise your internal links may be broken."); | |
1204 | } | |
1205 | } | |
1206 | ||
1207 | sub ComponentRoots { | |
1208 | my $self = shift; | |
1209 | my %args = ( Names => 0, @_ ); | |
1210 | my @roots; | |
1211 | if (defined $HTML::Mason::Commands::m) { | |
1212 | @roots = $HTML::Mason::Commands::m->interp->comp_root_array; | |
1213 | } else { | |
1214 | @roots = ( | |
1215 | [ local => $RT::MasonLocalComponentRoot ], | |
1216 | (map {[ "plugin-".$_->Name => $_->ComponentRoot ]} @{RT->Plugins}), | |
1217 | [ standard => $RT::MasonComponentRoot ] | |
1218 | ); | |
1219 | } | |
1220 | @roots = map { $_->[1] } @roots unless $args{Names}; | |
1221 | return @roots; | |
1222 | } | |
1223 | ||
b5747ff2 | 1224 | our %is_whitelisted_component = ( |
84fb5b46 MKG |
1225 | # The RSS feed embeds an auth token in the path, but query |
1226 | # information for the search. Because it's a straight-up read, in | |
1227 | # addition to embedding its own auth, it's fine. | |
1228 | '/NoAuth/rss/dhandler' => 1, | |
86404187 MKG |
1229 | |
1230 | # While these can be used for denial-of-service against RT | |
1231 | # (construct a very inefficient query and trick lots of users into | |
1232 | # running them against RT) it's incredibly useful to be able to link | |
1233 | # to a search result or bookmark a result page. | |
1234 | '/Search/Results.html' => 1, | |
1235 | '/Search/Simple.html' => 1, | |
1236 | '/m/tickets/search' => 1, | |
1237 | ); | |
1238 | ||
1239 | # Components which are blacklisted from automatic, argument-based whitelisting. | |
1240 | # These pages are not idempotent when called with just an id. | |
1241 | our %is_blacklisted_component = ( | |
1242 | # Takes only id and toggles bookmark state | |
1243 | '/Helpers/Toggle/TicketBookmark' => 1, | |
84fb5b46 MKG |
1244 | ); |
1245 | ||
1246 | sub IsCompCSRFWhitelisted { | |
1247 | my $comp = shift; | |
1248 | my $ARGS = shift; | |
1249 | ||
b5747ff2 | 1250 | return 1 if $is_whitelisted_component{$comp}; |
84fb5b46 MKG |
1251 | |
1252 | my %args = %{ $ARGS }; | |
1253 | ||
1254 | # If the user specifies a *correct* user and pass then they are | |
1255 | # golden. This acts on the presumption that external forms may | |
1256 | # hardcode a username and password -- if a malicious attacker knew | |
1257 | # both already, CSRF is the least of your problems. | |
1258 | my $AllowLoginCSRF = not RT->Config->Get('RestrictReferrerLogin'); | |
1259 | if ($AllowLoginCSRF and defined($args{user}) and defined($args{pass})) { | |
1260 | my $user_obj = RT::CurrentUser->new(); | |
1261 | $user_obj->Load($args{user}); | |
1262 | return 1 if $user_obj->id && $user_obj->IsPassword($args{pass}); | |
1263 | ||
1264 | delete $args{user}; | |
1265 | delete $args{pass}; | |
1266 | } | |
1267 | ||
86404187 MKG |
1268 | # Some pages aren't idempotent even with safe args like id; blacklist |
1269 | # them from the automatic whitelisting below. | |
1270 | return 0 if $is_blacklisted_component{$comp}; | |
1271 | ||
84fb5b46 MKG |
1272 | # Eliminate arguments that do not indicate an effectful request. |
1273 | # For example, "id" is acceptable because that is how RT retrieves a | |
1274 | # record. | |
1275 | delete $args{id}; | |
1276 | ||
1277 | # If they have a valid results= from MaybeRedirectForResults, that's | |
1278 | # also fine. | |
1279 | delete $args{results} if $args{results} | |
1280 | and $HTML::Mason::Commands::session{"Actions"}->{$args{results}}; | |
1281 | ||
b5747ff2 MKG |
1282 | # The homepage refresh, which uses the Refresh header, doesn't send |
1283 | # a referer in most browsers; whitelist the one parameter it reloads | |
1284 | # with, HomeRefreshInterval, which is safe | |
1285 | delete $args{HomeRefreshInterval}; | |
1286 | ||
84fb5b46 MKG |
1287 | # If there are no arguments, then it's likely to be an idempotent |
1288 | # request, which are not susceptible to CSRF | |
1289 | return 1 if !%args; | |
1290 | ||
1291 | return 0; | |
1292 | } | |
1293 | ||
1294 | sub IsRefererCSRFWhitelisted { | |
1295 | my $referer = _NormalizeHost(shift); | |
b5747ff2 MKG |
1296 | my $base_url = _NormalizeHost(RT->Config->Get('WebBaseURL')); |
1297 | $base_url = $base_url->host_port; | |
84fb5b46 | 1298 | |
b5747ff2 MKG |
1299 | my $configs; |
1300 | for my $config ( $base_url, RT->Config->Get('ReferrerWhitelist') ) { | |
1301 | push @$configs,$config; | |
86404187 MKG |
1302 | |
1303 | my $host_port = $referer->host_port; | |
1304 | if ($config =~ /\*/) { | |
1305 | # Turn a literal * into a domain component or partial component match. | |
1306 | # Refer to http://tools.ietf.org/html/rfc2818#page-5 | |
1307 | my $regex = join "[a-zA-Z0-9\-]*", | |
1308 | map { quotemeta($_) } | |
1309 | split /\*/, $config; | |
1310 | ||
1311 | return 1 if $host_port =~ /^$regex$/i; | |
1312 | } else { | |
1313 | return 1 if $host_port eq $config; | |
1314 | } | |
b5747ff2 | 1315 | } |
84fb5b46 | 1316 | |
b5747ff2 | 1317 | return (0,$referer,$configs); |
84fb5b46 MKG |
1318 | } |
1319 | ||
1320 | =head3 _NormalizeHost | |
1321 | ||
1322 | Takes a URI and creates a URI object that's been normalized | |
1323 | to handle common problems such as localhost vs 127.0.0.1 | |
1324 | ||
1325 | =cut | |
1326 | ||
1327 | sub _NormalizeHost { | |
1328 | ||
1329 | my $uri= URI->new(shift); | |
1330 | $uri->host('127.0.0.1') if $uri->host eq 'localhost'; | |
1331 | ||
1332 | return $uri; | |
1333 | ||
1334 | } | |
1335 | ||
1336 | sub IsPossibleCSRF { | |
1337 | my $ARGS = shift; | |
1338 | ||
1339 | # If first request on this session is to a REST endpoint, then | |
1340 | # whitelist the REST endpoints -- and explicitly deny non-REST | |
1341 | # endpoints. We do this because using a REST cookie in a browser | |
1342 | # would open the user to CSRF attacks to the REST endpoints. | |
1343 | my $path = $HTML::Mason::Commands::r->path_info; | |
1344 | $HTML::Mason::Commands::session{'REST'} = $path =~ m{^/+REST/\d+\.\d+(/|$)} | |
1345 | unless defined $HTML::Mason::Commands::session{'REST'}; | |
1346 | ||
1347 | if ($HTML::Mason::Commands::session{'REST'}) { | |
1348 | return 0 if $path =~ m{^/+REST/\d+\.\d+(/|$)}; | |
1349 | my $why = <<EOT; | |
1350 | This login session belongs to a REST client, and cannot be used to | |
1351 | access non-REST interfaces of RT for security reasons. | |
1352 | EOT | |
1353 | my $details = <<EOT; | |
1354 | Please log out and back in to obtain a session for normal browsing. If | |
1355 | you understand the security implications, disabling RT's CSRF protection | |
1356 | will remove this restriction. | |
1357 | EOT | |
1358 | chomp $details; | |
1359 | HTML::Mason::Commands::Abort( $why, Details => $details ); | |
1360 | } | |
1361 | ||
1362 | return 0 if IsCompCSRFWhitelisted( | |
1363 | $HTML::Mason::Commands::m->request_comp->path, | |
1364 | $ARGS | |
1365 | ); | |
1366 | ||
1367 | # if there is no Referer header then assume the worst | |
1368 | return (1, | |
1369 | "your browser did not supply a Referrer header", # loc | |
1370 | ) if !$ENV{HTTP_REFERER}; | |
1371 | ||
b5747ff2 | 1372 | my ($whitelisted, $browser, $configs) = IsRefererCSRFWhitelisted($ENV{HTTP_REFERER}); |
84fb5b46 MKG |
1373 | return 0 if $whitelisted; |
1374 | ||
b5747ff2 MKG |
1375 | if ( @$configs > 1 ) { |
1376 | return (1, | |
1377 | "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2]) or whitelisted hosts ([_3])", # loc | |
1378 | $browser->host_port, | |
1379 | shift @$configs, | |
1380 | join(', ', @$configs) ); | |
1381 | } | |
1382 | ||
84fb5b46 MKG |
1383 | return (1, |
1384 | "the Referrer header supplied by your browser ([_1]) is not allowed by RT's configured hostname ([_2])", # loc | |
b5747ff2 MKG |
1385 | $browser->host_port, |
1386 | $configs->[0]); | |
84fb5b46 MKG |
1387 | } |
1388 | ||
1389 | sub ExpandCSRFToken { | |
1390 | my $ARGS = shift; | |
1391 | ||
1392 | my $token = delete $ARGS->{CSRF_Token}; | |
1393 | return unless $token; | |
1394 | ||
1395 | my $data = $HTML::Mason::Commands::session{'CSRF'}{$token}; | |
1396 | return unless $data; | |
1397 | return unless $data->{path} eq $HTML::Mason::Commands::r->path_info; | |
1398 | ||
1399 | my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; | |
1400 | return unless $user->ValidateAuthString( $data->{auth}, $token ); | |
1401 | ||
1402 | %{$ARGS} = %{$data->{args}}; | |
b5747ff2 | 1403 | $HTML::Mason::Commands::DECODED_ARGS = $ARGS; |
84fb5b46 MKG |
1404 | |
1405 | # We explicitly stored file attachments with the request, but not in | |
1406 | # the session yet, as that would itself be an attack. Put them into | |
1407 | # the session now, so they'll be visible. | |
1408 | if ($data->{attach}) { | |
1409 | my $filename = $data->{attach}{filename}; | |
1410 | my $mime = $data->{attach}{mime}; | |
1411 | $HTML::Mason::Commands::session{'Attachments'}{$filename} | |
1412 | = $mime; | |
1413 | } | |
1414 | ||
1415 | return 1; | |
1416 | } | |
1417 | ||
b5747ff2 | 1418 | sub StoreRequestToken { |
84fb5b46 MKG |
1419 | my $ARGS = shift; |
1420 | ||
84fb5b46 MKG |
1421 | my $token = Digest::MD5::md5_hex(time . {} . $$ . rand(1024)); |
1422 | my $user = $HTML::Mason::Commands::session{'CurrentUser'}->UserObj; | |
1423 | my $data = { | |
1424 | auth => $user->GenerateAuthString( $token ), | |
1425 | path => $HTML::Mason::Commands::r->path_info, | |
1426 | args => $ARGS, | |
1427 | }; | |
1428 | if ($ARGS->{Attach}) { | |
1429 | my $attachment = HTML::Mason::Commands::MakeMIMEEntity( AttachmentFieldName => 'Attach' ); | |
1430 | my $file_path = delete $ARGS->{'Attach'}; | |
1431 | $data->{attach} = { | |
1432 | filename => Encode::decode_utf8("$file_path"), | |
1433 | mime => $attachment, | |
1434 | }; | |
1435 | } | |
1436 | ||
1437 | $HTML::Mason::Commands::session{'CSRF'}->{$token} = $data; | |
1438 | $HTML::Mason::Commands::session{'i'}++; | |
b5747ff2 MKG |
1439 | return $token; |
1440 | } | |
1441 | ||
1442 | sub MaybeShowInterstitialCSRFPage { | |
1443 | my $ARGS = shift; | |
1444 | ||
1445 | return unless RT->Config->Get('RestrictReferrer'); | |
1446 | ||
1447 | # Deal with the form token provided by the interstitial, which lets | |
1448 | # browsers which never set referer headers still use RT, if | |
1449 | # painfully. This blows values into ARGS | |
1450 | return if ExpandCSRFToken($ARGS); | |
1451 | ||
1452 | my ($is_csrf, $msg, @loc) = IsPossibleCSRF($ARGS); | |
1453 | return if !$is_csrf; | |
1454 | ||
1455 | $RT::Logger->notice("Possible CSRF: ".RT::CurrentUser->new->loc($msg, @loc)); | |
84fb5b46 | 1456 | |
b5747ff2 | 1457 | my $token = StoreRequestToken($ARGS); |
84fb5b46 MKG |
1458 | $HTML::Mason::Commands::m->comp( |
1459 | '/Elements/CSRF', | |
b5747ff2 | 1460 | OriginalURL => RT->Config->Get('WebPath') . $HTML::Mason::Commands::r->path_info, |
84fb5b46 MKG |
1461 | Reason => HTML::Mason::Commands::loc( $msg, @loc ), |
1462 | Token => $token, | |
1463 | ); | |
1464 | # Calls abort, never gets here | |
1465 | } | |
1466 | ||
86404187 MKG |
1467 | our @POTENTIAL_PAGE_ACTIONS = ( |
1468 | qr'/Ticket/Create.html' => "create a ticket", # loc | |
1469 | qr'/Ticket/' => "update a ticket", # loc | |
1470 | qr'/Admin/' => "modify RT's configuration", # loc | |
1471 | qr'/Approval/' => "update an approval", # loc | |
1472 | qr'/Articles/' => "update an article", # loc | |
1473 | qr'/Dashboards/' => "modify a dashboard", # loc | |
1474 | qr'/m/ticket/' => "update a ticket", # loc | |
1475 | qr'Prefs' => "modify your preferences", # loc | |
1476 | qr'/Search/' => "modify or access a search", # loc | |
1477 | qr'/SelfService/Create' => "create a ticket", # loc | |
1478 | qr'/SelfService/' => "update a ticket", # loc | |
1479 | ); | |
1480 | ||
1481 | sub PotentialPageAction { | |
1482 | my $page = shift; | |
1483 | my @potentials = @POTENTIAL_PAGE_ACTIONS; | |
1484 | while (my ($pattern, $result) = splice @potentials, 0, 2) { | |
1485 | return HTML::Mason::Commands::loc($result) | |
1486 | if $page =~ $pattern; | |
1487 | } | |
1488 | return ""; | |
1489 | } | |
1490 | ||
84fb5b46 MKG |
1491 | package HTML::Mason::Commands; |
1492 | ||
1493 | use vars qw/$r $m %session/; | |
1494 | ||
1495 | sub Menu { | |
1496 | return $HTML::Mason::Commands::m->notes('menu'); | |
1497 | } | |
1498 | ||
1499 | sub PageMenu { | |
1500 | return $HTML::Mason::Commands::m->notes('page-menu'); | |
1501 | } | |
1502 | ||
1503 | sub PageWidgets { | |
1504 | return $HTML::Mason::Commands::m->notes('page-widgets'); | |
1505 | } | |
1506 | ||
1507 | ||
1508 | ||
1509 | =head2 loc ARRAY | |
1510 | ||
1511 | loc is a nice clean global routine which calls $session{'CurrentUser'}->loc() | |
1512 | with whatever it's called with. If there is no $session{'CurrentUser'}, | |
1513 | it creates a temporary user, so we have something to get a localisation handle | |
1514 | through | |
1515 | ||
1516 | =cut | |
1517 | ||
1518 | sub loc { | |
1519 | ||
1520 | if ( $session{'CurrentUser'} | |
1521 | && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) ) | |
1522 | { | |
1523 | return ( $session{'CurrentUser'}->loc(@_) ); | |
1524 | } elsif ( | |
1525 | my $u = eval { | |
1526 | RT::CurrentUser->new(); | |
1527 | } | |
1528 | ) | |
1529 | { | |
1530 | return ( $u->loc(@_) ); | |
1531 | } else { | |
1532 | ||
1533 | # pathetic case -- SystemUser is gone. | |
1534 | return $_[0]; | |
1535 | } | |
1536 | } | |
1537 | ||
1538 | ||
1539 | ||
1540 | =head2 loc_fuzzy STRING | |
1541 | ||
1542 | loc_fuzzy is for handling localizations of messages that may already | |
1543 | contain interpolated variables, typically returned from libraries | |
1544 | outside RT's control. It takes the message string and extracts the | |
1545 | variable array automatically by matching against the candidate entries | |
1546 | inside the lexicon file. | |
1547 | ||
1548 | =cut | |
1549 | ||
1550 | sub loc_fuzzy { | |
1551 | my $msg = shift; | |
1552 | ||
1553 | if ( $session{'CurrentUser'} | |
1554 | && UNIVERSAL::can( $session{'CurrentUser'}, 'loc' ) ) | |
1555 | { | |
1556 | return ( $session{'CurrentUser'}->loc_fuzzy($msg) ); | |
1557 | } else { | |
1558 | my $u = RT::CurrentUser->new( RT->SystemUser->Id ); | |
1559 | return ( $u->loc_fuzzy($msg) ); | |
1560 | } | |
1561 | } | |
1562 | ||
1563 | ||
1564 | # Error - calls Error and aborts | |
1565 | sub Abort { | |
1566 | my $why = shift; | |
1567 | my %args = @_; | |
1568 | ||
1569 | if ( $session{'ErrorDocument'} | |
1570 | && $session{'ErrorDocumentType'} ) | |
1571 | { | |
1572 | $r->content_type( $session{'ErrorDocumentType'} ); | |
1573 | $m->comp( $session{'ErrorDocument'}, Why => $why, %args ); | |
1574 | $m->abort; | |
1575 | } else { | |
1576 | $m->comp( "/Elements/Error", Why => $why, %args ); | |
1577 | $m->abort; | |
1578 | } | |
1579 | } | |
1580 | ||
1581 | sub MaybeRedirectForResults { | |
1582 | my %args = ( | |
1583 | Path => $HTML::Mason::Commands::m->request_comp->path, | |
1584 | Arguments => {}, | |
1585 | Anchor => undef, | |
1586 | Actions => undef, | |
1587 | Force => 0, | |
1588 | @_ | |
1589 | ); | |
1590 | my $has_actions = $args{'Actions'} && grep( defined, @{ $args{'Actions'} } ); | |
1591 | return unless $has_actions || $args{'Force'}; | |
1592 | ||
1593 | my %arguments = %{ $args{'Arguments'} }; | |
1594 | ||
1595 | if ( $has_actions ) { | |
1596 | my $key = Digest::MD5::md5_hex( rand(1024) ); | |
1597 | push @{ $session{"Actions"}{ $key } ||= [] }, @{ $args{'Actions'} }; | |
1598 | $session{'i'}++; | |
1599 | $arguments{'results'} = $key; | |
1600 | } | |
1601 | ||
1602 | $args{'Path'} =~ s!^/+!!; | |
1603 | my $url = RT->Config->Get('WebURL') . $args{Path}; | |
1604 | ||
1605 | if ( keys %arguments ) { | |
1606 | $url .= '?'. $m->comp( '/Elements/QueryString', %arguments ); | |
1607 | } | |
1608 | if ( $args{'Anchor'} ) { | |
1609 | $url .= "#". $args{'Anchor'}; | |
1610 | } | |
1611 | return RT::Interface::Web::Redirect($url); | |
1612 | } | |
1613 | ||
1614 | =head2 MaybeRedirectToApproval Path => 'path', Whitelist => REGEX, ARGSRef => HASHREF | |
1615 | ||
1616 | If the ticket specified by C<< $ARGSRef->{id} >> is an approval ticket, | |
1617 | redirect to the approvals display page, preserving any arguments. | |
1618 | ||
1619 | C<Path>s matching C<Whitelist> are let through. | |
1620 | ||
1621 | This is a no-op if the C<ForceApprovalsView> option isn't enabled. | |
1622 | ||
1623 | =cut | |
1624 | ||
1625 | sub MaybeRedirectToApproval { | |
1626 | my %args = ( | |
1627 | Path => $HTML::Mason::Commands::m->request_comp->path, | |
1628 | ARGSRef => {}, | |
1629 | Whitelist => undef, | |
1630 | @_ | |
1631 | ); | |
1632 | ||
1633 | return unless $ENV{REQUEST_METHOD} eq 'GET'; | |
1634 | ||
1635 | my $id = $args{ARGSRef}->{id}; | |
1636 | ||
1637 | if ( $id | |
1638 | and RT->Config->Get('ForceApprovalsView') | |
1639 | and not $args{Path} =~ /$args{Whitelist}/) | |
1640 | { | |
1641 | my $ticket = RT::Ticket->new( $session{'CurrentUser'} ); | |
1642 | $ticket->Load($id); | |
1643 | ||
1644 | if ($ticket and $ticket->id and lc($ticket->Type) eq 'approval') { | |
1645 | MaybeRedirectForResults( | |
1646 | Path => "/Approvals/Display.html", | |
1647 | Force => 1, | |
1648 | Anchor => $args{ARGSRef}->{Anchor}, | |
1649 | Arguments => $args{ARGSRef}, | |
1650 | ); | |
1651 | } | |
1652 | } | |
1653 | } | |
1654 | ||
1655 | =head2 CreateTicket ARGS | |
1656 | ||
1657 | Create a new ticket, using Mason's %ARGS. returns @results. | |
1658 | ||
1659 | =cut | |
1660 | ||
1661 | sub CreateTicket { | |
1662 | my %ARGS = (@_); | |
1663 | ||
1664 | my (@Actions); | |
1665 | ||
1666 | my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); | |
1667 | ||
1668 | my $Queue = RT::Queue->new( $session{'CurrentUser'} ); | |
1669 | unless ( $Queue->Load( $ARGS{'Queue'} ) ) { | |
1670 | Abort('Queue not found'); | |
1671 | } | |
1672 | ||
1673 | unless ( $Queue->CurrentUserHasRight('CreateTicket') ) { | |
1674 | Abort('You have no permission to create tickets in that queue.'); | |
1675 | } | |
1676 | ||
1677 | my $due; | |
1678 | if ( defined $ARGS{'Due'} and $ARGS{'Due'} =~ /\S/ ) { | |
1679 | $due = RT::Date->new( $session{'CurrentUser'} ); | |
1680 | $due->Set( Format => 'unknown', Value => $ARGS{'Due'} ); | |
1681 | } | |
1682 | my $starts; | |
1683 | if ( defined $ARGS{'Starts'} and $ARGS{'Starts'} =~ /\S/ ) { | |
1684 | $starts = RT::Date->new( $session{'CurrentUser'} ); | |
1685 | $starts->Set( Format => 'unknown', Value => $ARGS{'Starts'} ); | |
1686 | } | |
1687 | ||
1688 | my $sigless = RT::Interface::Web::StripContent( | |
1689 | Content => $ARGS{Content}, | |
1690 | ContentType => $ARGS{ContentType}, | |
1691 | StripSignature => 1, | |
1692 | CurrentUser => $session{'CurrentUser'}, | |
1693 | ); | |
1694 | ||
1695 | my $MIMEObj = MakeMIMEEntity( | |
1696 | Subject => $ARGS{'Subject'}, | |
1697 | From => $ARGS{'From'}, | |
1698 | Cc => $ARGS{'Cc'}, | |
1699 | Body => $sigless, | |
1700 | Type => $ARGS{'ContentType'}, | |
1701 | ); | |
1702 | ||
1703 | if ( $ARGS{'Attachments'} ) { | |
1704 | my $rv = $MIMEObj->make_multipart; | |
1705 | $RT::Logger->error("Couldn't make multipart message") | |
1706 | if !$rv || $rv !~ /^(?:DONE|ALREADY)$/; | |
1707 | ||
1708 | foreach ( values %{ $ARGS{'Attachments'} } ) { | |
1709 | unless ($_) { | |
1710 | $RT::Logger->error("Couldn't add empty attachemnt"); | |
1711 | next; | |
1712 | } | |
1713 | $MIMEObj->add_part($_); | |
1714 | } | |
1715 | } | |
1716 | ||
86404187 MKG |
1717 | for my $argument (qw(Encrypt Sign)) { |
1718 | $MIMEObj->head->replace( "X-RT-$argument" => $ARGS{$argument} ? 1 : 0 ); | |
84fb5b46 MKG |
1719 | } |
1720 | ||
1721 | my %create_args = ( | |
1722 | Type => $ARGS{'Type'} || 'ticket', | |
1723 | Queue => $ARGS{'Queue'}, | |
1724 | Owner => $ARGS{'Owner'}, | |
1725 | ||
1726 | # note: name change | |
1727 | Requestor => $ARGS{'Requestors'}, | |
1728 | Cc => $ARGS{'Cc'}, | |
1729 | AdminCc => $ARGS{'AdminCc'}, | |
1730 | InitialPriority => $ARGS{'InitialPriority'}, | |
1731 | FinalPriority => $ARGS{'FinalPriority'}, | |
1732 | TimeLeft => $ARGS{'TimeLeft'}, | |
1733 | TimeEstimated => $ARGS{'TimeEstimated'}, | |
1734 | TimeWorked => $ARGS{'TimeWorked'}, | |
1735 | Subject => $ARGS{'Subject'}, | |
1736 | Status => $ARGS{'Status'}, | |
1737 | Due => $due ? $due->ISO : undef, | |
1738 | Starts => $starts ? $starts->ISO : undef, | |
1739 | MIMEObj => $MIMEObj | |
1740 | ); | |
1741 | ||
1742 | my @txn_squelch; | |
1743 | foreach my $type (qw(Requestor Cc AdminCc)) { | |
1744 | push @txn_squelch, map $_->address, Email::Address->parse( $create_args{$type} ) | |
1745 | if grep $_ eq $type || $_ eq ( $type . 's' ), @{ $ARGS{'SkipNotification'} || [] }; | |
1746 | } | |
1747 | $create_args{TransSquelchMailTo} = \@txn_squelch | |
1748 | if @txn_squelch; | |
1749 | ||
1750 | if ( $ARGS{'AttachTickets'} ) { | |
1751 | require RT::Action::SendEmail; | |
1752 | RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets, | |
1753 | ref $ARGS{'AttachTickets'} | |
1754 | ? @{ $ARGS{'AttachTickets'} } | |
1755 | : ( $ARGS{'AttachTickets'} ) ); | |
1756 | } | |
1757 | ||
1758 | foreach my $arg ( keys %ARGS ) { | |
1759 | next if $arg =~ /-(?:Magic|Category)$/; | |
1760 | ||
1761 | if ( $arg =~ /^Object-RT::Transaction--CustomField-/ ) { | |
1762 | $create_args{$arg} = $ARGS{$arg}; | |
1763 | } | |
1764 | ||
1765 | # Object-RT::Ticket--CustomField-3-Values | |
1766 | elsif ( $arg =~ /^Object-RT::Ticket--CustomField-(\d+)/ ) { | |
1767 | my $cfid = $1; | |
1768 | ||
1769 | my $cf = RT::CustomField->new( $session{'CurrentUser'} ); | |
1770 | $cf->SetContextObject( $Queue ); | |
1771 | $cf->Load($cfid); | |
1772 | unless ( $cf->id ) { | |
1773 | $RT::Logger->error( "Couldn't load custom field #" . $cfid ); | |
1774 | next; | |
1775 | } | |
1776 | ||
1777 | if ( $arg =~ /-Upload$/ ) { | |
1778 | $create_args{"CustomField-$cfid"} = _UploadedFile($arg); | |
1779 | next; | |
1780 | } | |
1781 | ||
1782 | my $type = $cf->Type; | |
1783 | ||
1784 | my @values = (); | |
1785 | if ( ref $ARGS{$arg} eq 'ARRAY' ) { | |
1786 | @values = @{ $ARGS{$arg} }; | |
1787 | } elsif ( $type =~ /text/i ) { | |
1788 | @values = ( $ARGS{$arg} ); | |
1789 | } else { | |
1790 | no warnings 'uninitialized'; | |
1791 | @values = split /\r*\n/, $ARGS{$arg}; | |
1792 | } | |
1793 | @values = grep length, map { | |
1794 | s/\r+\n/\n/g; | |
1795 | s/^\s+//; | |
1796 | s/\s+$//; | |
1797 | $_; | |
1798 | } | |
1799 | grep defined, @values; | |
1800 | ||
1801 | $create_args{"CustomField-$cfid"} = \@values; | |
1802 | } | |
1803 | } | |
1804 | ||
1805 | # turn new link lists into arrays, and pass in the proper arguments | |
1806 | my %map = ( | |
1807 | 'new-DependsOn' => 'DependsOn', | |
1808 | 'DependsOn-new' => 'DependedOnBy', | |
1809 | 'new-MemberOf' => 'Parents', | |
1810 | 'MemberOf-new' => 'Children', | |
1811 | 'new-RefersTo' => 'RefersTo', | |
1812 | 'RefersTo-new' => 'ReferredToBy', | |
1813 | ); | |
1814 | foreach my $key ( keys %map ) { | |
1815 | next unless $ARGS{$key}; | |
1816 | $create_args{ $map{$key} } = [ grep $_, split ' ', $ARGS{$key} ]; | |
1817 | ||
1818 | } | |
1819 | ||
1820 | my ( $id, $Trans, $ErrMsg ) = $Ticket->Create(%create_args); | |
1821 | unless ($id) { | |
1822 | Abort($ErrMsg); | |
1823 | } | |
1824 | ||
1825 | push( @Actions, split( "\n", $ErrMsg ) ); | |
1826 | unless ( $Ticket->CurrentUserHasRight('ShowTicket') ) { | |
1827 | Abort( "No permission to view newly created ticket #" . $Ticket->id . "." ); | |
1828 | } | |
1829 | return ( $Ticket, @Actions ); | |
1830 | ||
1831 | } | |
1832 | ||
1833 | ||
1834 | ||
1835 | =head2 LoadTicket id | |
1836 | ||
1837 | Takes a ticket id as its only variable. if it's handed an array, it takes | |
1838 | the first value. | |
1839 | ||
1840 | Returns an RT::Ticket object as the current user. | |
1841 | ||
1842 | =cut | |
1843 | ||
1844 | sub LoadTicket { | |
1845 | my $id = shift; | |
1846 | ||
1847 | if ( ref($id) eq "ARRAY" ) { | |
1848 | $id = $id->[0]; | |
1849 | } | |
1850 | ||
1851 | unless ($id) { | |
1852 | Abort("No ticket specified"); | |
1853 | } | |
1854 | ||
1855 | my $Ticket = RT::Ticket->new( $session{'CurrentUser'} ); | |
1856 | $Ticket->Load($id); | |
1857 | unless ( $Ticket->id ) { | |
1858 | Abort("Could not load ticket $id"); | |
1859 | } | |
1860 | return $Ticket; | |
1861 | } | |
1862 | ||
1863 | ||
1864 | ||
1865 | =head2 ProcessUpdateMessage | |
1866 | ||
1867 | Takes paramhash with fields ARGSRef, TicketObj and SkipSignatureOnly. | |
1868 | ||
1869 | Don't write message if it only contains current user's signature and | |
1870 | SkipSignatureOnly argument is true. Function anyway adds attachments | |
1871 | and updates time worked field even if skips message. The default value | |
1872 | is true. | |
1873 | ||
1874 | =cut | |
1875 | ||
1876 | sub ProcessUpdateMessage { | |
1877 | ||
1878 | my %args = ( | |
1879 | ARGSRef => undef, | |
1880 | TicketObj => undef, | |
1881 | SkipSignatureOnly => 1, | |
1882 | @_ | |
1883 | ); | |
1884 | ||
1885 | if ( $args{ARGSRef}->{'UpdateAttachments'} | |
1886 | && !keys %{ $args{ARGSRef}->{'UpdateAttachments'} } ) | |
1887 | { | |
1888 | delete $args{ARGSRef}->{'UpdateAttachments'}; | |
1889 | } | |
1890 | ||
1891 | # Strip the signature | |
1892 | $args{ARGSRef}->{UpdateContent} = RT::Interface::Web::StripContent( | |
1893 | Content => $args{ARGSRef}->{UpdateContent}, | |
1894 | ContentType => $args{ARGSRef}->{UpdateContentType}, | |
1895 | StripSignature => $args{SkipSignatureOnly}, | |
1896 | CurrentUser => $args{'TicketObj'}->CurrentUser, | |
1897 | ); | |
1898 | ||
1899 | # If, after stripping the signature, we have no message, move the | |
1900 | # UpdateTimeWorked into adjusted TimeWorked, so that a later | |
1901 | # ProcessBasics can deal -- then bail out. | |
1902 | if ( not $args{ARGSRef}->{'UpdateAttachments'} | |
1903 | and not length $args{ARGSRef}->{'UpdateContent'} ) | |
1904 | { | |
1905 | if ( $args{ARGSRef}->{'UpdateTimeWorked'} ) { | |
1906 | $args{ARGSRef}->{TimeWorked} = $args{TicketObj}->TimeWorked + delete $args{ARGSRef}->{'UpdateTimeWorked'}; | |
1907 | } | |
1908 | return; | |
1909 | } | |
1910 | ||
1911 | if ( $args{ARGSRef}->{'UpdateSubject'} eq ($args{'TicketObj'}->Subject || '') ) { | |
1912 | $args{ARGSRef}->{'UpdateSubject'} = undef; | |
1913 | } | |
1914 | ||
1915 | my $Message = MakeMIMEEntity( | |
1916 | Subject => $args{ARGSRef}->{'UpdateSubject'}, | |
1917 | Body => $args{ARGSRef}->{'UpdateContent'}, | |
1918 | Type => $args{ARGSRef}->{'UpdateContentType'}, | |
1919 | ); | |
1920 | ||
1921 | $Message->head->replace( 'Message-ID' => Encode::encode_utf8( | |
1922 | RT::Interface::Email::GenMessageId( Ticket => $args{'TicketObj'} ) | |
1923 | ) ); | |
1924 | my $old_txn = RT::Transaction->new( $session{'CurrentUser'} ); | |
1925 | if ( $args{ARGSRef}->{'QuoteTransaction'} ) { | |
1926 | $old_txn->Load( $args{ARGSRef}->{'QuoteTransaction'} ); | |
1927 | } else { | |
1928 | $old_txn = $args{TicketObj}->Transactions->First(); | |
1929 | } | |
1930 | ||
1931 | if ( my $msg = $old_txn->Message->First ) { | |
1932 | RT::Interface::Email::SetInReplyTo( | |
1933 | Message => $Message, | |
1934 | InReplyTo => $msg | |
1935 | ); | |
1936 | } | |
1937 | ||
1938 | if ( $args{ARGSRef}->{'UpdateAttachments'} ) { | |
1939 | $Message->make_multipart; | |
1940 | $Message->add_part($_) foreach values %{ $args{ARGSRef}->{'UpdateAttachments'} }; | |
1941 | } | |
1942 | ||
1943 | if ( $args{ARGSRef}->{'AttachTickets'} ) { | |
1944 | require RT::Action::SendEmail; | |
1945 | RT::Action::SendEmail->AttachTickets( RT::Action::SendEmail->AttachTickets, | |
1946 | ref $args{ARGSRef}->{'AttachTickets'} | |
1947 | ? @{ $args{ARGSRef}->{'AttachTickets'} } | |
1948 | : ( $args{ARGSRef}->{'AttachTickets'} ) ); | |
1949 | } | |
1950 | ||
1951 | my %message_args = ( | |
1952 | Sign => ( $args{ARGSRef}->{'Sign'} ? 1 : 0 ), | |
1953 | Encrypt => ( $args{ARGSRef}->{'Encrypt'} ? 1 : 0 ), | |
1954 | MIMEObj => $Message, | |
1955 | TimeTaken => $args{ARGSRef}->{'UpdateTimeWorked'} | |
1956 | ); | |
1957 | ||
1958 | _ProcessUpdateMessageRecipients( | |
1959 | MessageArgs => \%message_args, | |
1960 | %args, | |
1961 | ); | |
1962 | ||
1963 | my @results; | |
1964 | if ( $args{ARGSRef}->{'UpdateType'} =~ /^(private|public)$/ ) { | |
1965 | my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Comment(%message_args); | |
1966 | push( @results, $Description ); | |
1967 | $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; | |
1968 | } elsif ( $args{ARGSRef}->{'UpdateType'} eq 'response' ) { | |
1969 | my ( $Transaction, $Description, $Object ) = $args{TicketObj}->Correspond(%message_args); | |
1970 | push( @results, $Description ); | |
1971 | $Object->UpdateCustomFields( ARGSRef => $args{ARGSRef} ) if $Object; | |
1972 | } else { | |
1973 | push( @results, | |
1974 | loc("Update type was neither correspondence nor comment.") . " " . loc("Update not recorded.") ); | |
1975 | } | |
1976 | return @results; | |
1977 | } | |
1978 | ||
1979 | sub _ProcessUpdateMessageRecipients { | |
1980 | my %args = ( | |
1981 | ARGSRef => undef, | |
1982 | TicketObj => undef, | |
1983 | MessageArgs => undef, | |
1984 | @_, | |
1985 | ); | |
1986 | ||
1987 | my $bcc = $args{ARGSRef}->{'UpdateBcc'}; | |
1988 | my $cc = $args{ARGSRef}->{'UpdateCc'}; | |
1989 | ||
1990 | my $message_args = $args{MessageArgs}; | |
1991 | ||
1992 | $message_args->{CcMessageTo} = $cc; | |
1993 | $message_args->{BccMessageTo} = $bcc; | |
1994 | ||
1995 | my @txn_squelch; | |
1996 | foreach my $type (qw(Cc AdminCc)) { | |
1997 | if (grep $_ eq $type || $_ eq ( $type . 's' ), @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { | |
1998 | push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{$type} ); | |
1999 | push @txn_squelch, $args{TicketObj}->$type->MemberEmailAddresses; | |
2000 | push @txn_squelch, $args{TicketObj}->QueueObj->$type->MemberEmailAddresses; | |
2001 | } | |
2002 | } | |
2003 | if (grep $_ eq 'Requestor' || $_ eq 'Requestors', @{ $args{ARGSRef}->{'SkipNotification'} || [] }) { | |
2004 | push @txn_squelch, map $_->address, Email::Address->parse( $message_args->{Requestor} ); | |
2005 | push @txn_squelch, $args{TicketObj}->Requestors->MemberEmailAddresses; | |
2006 | } | |
2007 | ||
2008 | push @txn_squelch, @{$args{ARGSRef}{SquelchMailTo}} if $args{ARGSRef}{SquelchMailTo}; | |
2009 | $message_args->{SquelchMailTo} = \@txn_squelch | |
2010 | if @txn_squelch; | |
2011 | ||
2012 | unless ( $args{'ARGSRef'}->{'UpdateIgnoreAddressCheckboxes'} ) { | |
2013 | foreach my $key ( keys %{ $args{ARGSRef} } ) { | |
2014 | next unless $key =~ /^Update(Cc|Bcc)-(.*)$/; | |
2015 | ||
2016 | my $var = ucfirst($1) . 'MessageTo'; | |
2017 | my $value = $2; | |
2018 | if ( $message_args->{$var} ) { | |
2019 | $message_args->{$var} .= ", $value"; | |
2020 | } else { | |
2021 | $message_args->{$var} = $value; | |
2022 | } | |
2023 | } | |
2024 | } | |
2025 | } | |
2026 | ||
2027 | ||
2028 | ||
2029 | =head2 MakeMIMEEntity PARAMHASH | |
2030 | ||
2031 | Takes a paramhash Subject, Body and AttachmentFieldName. | |
2032 | ||
2033 | Also takes Form, Cc and Type as optional paramhash keys. | |
2034 | ||
2035 | Returns a MIME::Entity. | |
2036 | ||
2037 | =cut | |
2038 | ||
2039 | sub MakeMIMEEntity { | |
2040 | ||
2041 | #TODO document what else this takes. | |
2042 | my %args = ( | |
2043 | Subject => undef, | |
2044 | From => undef, | |
2045 | Cc => undef, | |
2046 | Body => undef, | |
2047 | AttachmentFieldName => undef, | |
2048 | Type => undef, | |
2049 | @_, | |
2050 | ); | |
2051 | my $Message = MIME::Entity->build( | |
2052 | Type => 'multipart/mixed', | |
86404187 | 2053 | "Message-Id" => Encode::encode_utf8( RT::Interface::Email::GenMessageId ), |
84fb5b46 MKG |
2054 | map { $_ => Encode::encode_utf8( $args{ $_} ) } |
2055 | grep defined $args{$_}, qw(Subject From Cc) | |
2056 | ); | |
2057 | ||
2058 | if ( defined $args{'Body'} && length $args{'Body'} ) { | |
2059 | ||
2060 | # Make the update content have no 'weird' newlines in it | |
2061 | $args{'Body'} =~ s/\r\n/\n/gs; | |
2062 | ||
2063 | $Message->attach( | |
2064 | Type => $args{'Type'} || 'text/plain', | |
2065 | Charset => 'UTF-8', | |
2066 | Data => $args{'Body'}, | |
2067 | ); | |
2068 | } | |
2069 | ||
2070 | if ( $args{'AttachmentFieldName'} ) { | |
2071 | ||
2072 | my $cgi_object = $m->cgi_object; | |
2073 | my $filehandle = $cgi_object->upload( $args{'AttachmentFieldName'} ); | |
2074 | if ( defined $filehandle && length $filehandle ) { | |
2075 | ||
2076 | my ( @content, $buffer ); | |
2077 | while ( my $bytesread = read( $filehandle, $buffer, 4096 ) ) { | |
2078 | push @content, $buffer; | |
2079 | } | |
2080 | ||
2081 | my $uploadinfo = $cgi_object->uploadInfo($filehandle); | |
2082 | ||
2083 | my $filename = "$filehandle"; | |
2084 | $filename =~ s{^.*[\\/]}{}; | |
2085 | ||
2086 | $Message->attach( | |
2087 | Type => $uploadinfo->{'Content-Type'}, | |
2088 | Filename => $filename, | |
2089 | Data => \@content, | |
2090 | ); | |
2091 | if ( !$args{'Subject'} && !( defined $args{'Body'} && length $args{'Body'} ) ) { | |
2092 | $Message->head->set( 'Subject' => $filename ); | |
2093 | } | |
2094 | ||
2095 | # Attachment parts really shouldn't get a Message-ID | |
2096 | $Message->head->delete('Message-ID'); | |
2097 | } | |
2098 | } | |
2099 | ||
2100 | $Message->make_singlepart; | |
2101 | ||
2102 | RT::I18N::SetMIMEEntityToUTF8($Message); # convert text parts into utf-8 | |
2103 | ||
2104 | return ($Message); | |
2105 | ||
2106 | } | |
2107 | ||
2108 | ||
2109 | ||
2110 | =head2 ParseDateToISO | |
2111 | ||
2112 | Takes a date in an arbitrary format. | |
2113 | Returns an ISO date and time in GMT | |
2114 | ||
2115 | =cut | |
2116 | ||
2117 | sub ParseDateToISO { | |
2118 | my $date = shift; | |
2119 | ||
2120 | my $date_obj = RT::Date->new( $session{'CurrentUser'} ); | |
2121 | $date_obj->Set( | |
2122 | Format => 'unknown', | |
2123 | Value => $date | |
2124 | ); | |
2125 | return ( $date_obj->ISO ); | |
2126 | } | |
2127 | ||
2128 | ||
2129 | ||
2130 | sub ProcessACLChanges { | |
2131 | my $ARGSref = shift; | |
2132 | ||
2133 | #XXX: why don't we get ARGSref like in other Process* subs? | |
2134 | ||
2135 | my @results; | |
2136 | ||
2137 | foreach my $arg ( keys %$ARGSref ) { | |
2138 | next unless ( $arg =~ /^(GrantRight|RevokeRight)-(\d+)-(.+?)-(\d+)$/ ); | |
2139 | ||
2140 | my ( $method, $principal_id, $object_type, $object_id ) = ( $1, $2, $3, $4 ); | |
2141 | ||
2142 | my @rights; | |
2143 | if ( UNIVERSAL::isa( $ARGSref->{$arg}, 'ARRAY' ) ) { | |
2144 | @rights = @{ $ARGSref->{$arg} }; | |
2145 | } else { | |
2146 | @rights = $ARGSref->{$arg}; | |
2147 | } | |
2148 | @rights = grep $_, @rights; | |
2149 | next unless @rights; | |
2150 | ||
2151 | my $principal = RT::Principal->new( $session{'CurrentUser'} ); | |
2152 | $principal->Load($principal_id); | |
2153 | ||
2154 | my $obj; | |
2155 | if ( $object_type eq 'RT::System' ) { | |
2156 | $obj = $RT::System; | |
2157 | } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { | |
2158 | $obj = $object_type->new( $session{'CurrentUser'} ); | |
2159 | $obj->Load($object_id); | |
2160 | unless ( $obj->id ) { | |
2161 | $RT::Logger->error("couldn't load $object_type #$object_id"); | |
2162 | next; | |
2163 | } | |
2164 | } else { | |
2165 | $RT::Logger->error("object type '$object_type' is incorrect"); | |
2166 | push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) ); | |
2167 | next; | |
2168 | } | |
2169 | ||
2170 | foreach my $right (@rights) { | |
2171 | my ( $val, $msg ) = $principal->$method( Object => $obj, Right => $right ); | |
2172 | push( @results, $msg ); | |
2173 | } | |
2174 | } | |
2175 | ||
2176 | return (@results); | |
2177 | } | |
2178 | ||
2179 | ||
2180 | =head2 ProcessACLs | |
2181 | ||
2182 | ProcessACLs expects values from a series of checkboxes that describe the full | |
2183 | set of rights a principal should have on an object. | |
2184 | ||
2185 | It expects form inputs with names like SetRights-PrincipalId-ObjType-ObjId | |
2186 | instead of with the prefixes Grant/RevokeRight. Each input should be an array | |
2187 | listing the rights the principal should have, and ProcessACLs will modify the | |
2188 | current rights to match. Additionally, the previously unused CheckACL input | |
2189 | listing PrincipalId-ObjType-ObjId is now used to catch cases when all the | |
2190 | rights are removed from a principal and as such no SetRights input is | |
2191 | submitted. | |
2192 | ||
2193 | =cut | |
2194 | ||
2195 | sub ProcessACLs { | |
2196 | my $ARGSref = shift; | |
2197 | my (%state, @results); | |
2198 | ||
2199 | my $CheckACL = $ARGSref->{'CheckACL'}; | |
2200 | my @check = grep { defined } (ref $CheckACL eq 'ARRAY' ? @$CheckACL : $CheckACL); | |
2201 | ||
2202 | # Check if we want to grant rights to a previously rights-less user | |
2203 | for my $type (qw(user group)) { | |
2204 | my $key = "AddPrincipalForRights-$type"; | |
2205 | ||
2206 | next unless $ARGSref->{$key}; | |
2207 | ||
2208 | my $principal; | |
2209 | if ( $type eq 'user' ) { | |
2210 | $principal = RT::User->new( $session{'CurrentUser'} ); | |
2211 | $principal->LoadByCol( Name => $ARGSref->{$key} ); | |
2212 | } | |
2213 | else { | |
2214 | $principal = RT::Group->new( $session{'CurrentUser'} ); | |
2215 | $principal->LoadUserDefinedGroup( $ARGSref->{$key} ); | |
2216 | } | |
2217 | ||
2218 | unless ($principal->PrincipalId) { | |
2219 | push @results, loc("Couldn't load the specified principal"); | |
2220 | next; | |
2221 | } | |
2222 | ||
2223 | my $principal_id = $principal->PrincipalId; | |
2224 | ||
2225 | # Turn our addprincipal rights spec into a real one | |
2226 | for my $arg (keys %$ARGSref) { | |
2227 | next unless $arg =~ /^SetRights-addprincipal-(.+?-\d+)$/; | |
2228 | ||
2229 | my $tuple = "$principal_id-$1"; | |
2230 | my $key = "SetRights-$tuple"; | |
2231 | ||
2232 | # If we have it already, that's odd, but merge them | |
2233 | if (grep { $_ eq $tuple } @check) { | |
2234 | $ARGSref->{$key} = [ | |
2235 | (ref $ARGSref->{$key} eq 'ARRAY' ? @{$ARGSref->{$key}} : $ARGSref->{$key}), | |
2236 | (ref $ARGSref->{$arg} eq 'ARRAY' ? @{$ARGSref->{$arg}} : $ARGSref->{$arg}), | |
2237 | ]; | |
2238 | } else { | |
2239 | $ARGSref->{$key} = $ARGSref->{$arg}; | |
2240 | push @check, $tuple; | |
2241 | } | |
2242 | } | |
2243 | } | |
2244 | ||
2245 | # Build our rights state for each Principal-Object tuple | |
2246 | foreach my $arg ( keys %$ARGSref ) { | |
2247 | next unless $arg =~ /^SetRights-(\d+-.+?-\d+)$/; | |
2248 | ||
2249 | my $tuple = $1; | |
2250 | my $value = $ARGSref->{$arg}; | |
2251 | my @rights = grep { $_ } (ref $value eq 'ARRAY' ? @$value : $value); | |
2252 | next unless @rights; | |
2253 | ||
2254 | $state{$tuple} = { map { $_ => 1 } @rights }; | |
2255 | } | |
2256 | ||
2257 | foreach my $tuple (List::MoreUtils::uniq @check) { | |
2258 | next unless $tuple =~ /^(\d+)-(.+?)-(\d+)$/; | |
2259 | ||
2260 | my ( $principal_id, $object_type, $object_id ) = ( $1, $2, $3 ); | |
2261 | ||
2262 | my $principal = RT::Principal->new( $session{'CurrentUser'} ); | |
2263 | $principal->Load($principal_id); | |
2264 | ||
2265 | my $obj; | |
2266 | if ( $object_type eq 'RT::System' ) { | |
2267 | $obj = $RT::System; | |
2268 | } elsif ( $RT::ACE::OBJECT_TYPES{$object_type} ) { | |
2269 | $obj = $object_type->new( $session{'CurrentUser'} ); | |
2270 | $obj->Load($object_id); | |
2271 | unless ( $obj->id ) { | |
2272 | $RT::Logger->error("couldn't load $object_type #$object_id"); | |
2273 | next; | |
2274 | } | |
2275 | } else { | |
2276 | $RT::Logger->error("object type '$object_type' is incorrect"); | |
2277 | push( @results, loc("System Error") . ': ' . loc( "Rights could not be granted for [_1]", $object_type ) ); | |
2278 | next; | |
2279 | } | |
2280 | ||
2281 | my $acls = RT::ACL->new($session{'CurrentUser'}); | |
2282 | $acls->LimitToObject( $obj ); | |
2283 | $acls->LimitToPrincipal( Id => $principal_id ); | |
2284 | ||
2285 | while ( my $ace = $acls->Next ) { | |
2286 | my $right = $ace->RightName; | |
2287 | ||
2288 | # Has right and should have right | |
2289 | next if delete $state{$tuple}->{$right}; | |
2290 | ||
2291 | # Has right and shouldn't have right | |
2292 | my ($val, $msg) = $principal->RevokeRight( Object => $obj, Right => $right ); | |
2293 | push @results, $msg; | |
2294 | } | |
2295 | ||
2296 | # For everything left, they don't have the right but they should | |
2297 | for my $right (keys %{ $state{$tuple} || {} }) { | |
2298 | delete $state{$tuple}->{$right}; | |
2299 | my ($val, $msg) = $principal->GrantRight( Object => $obj, Right => $right ); | |
2300 | push @results, $msg; | |
2301 | } | |
2302 | ||
2303 | # Check our state for leftovers | |
2304 | if ( keys %{ $state{$tuple} || {} } ) { | |
2305 | my $missed = join '|', %{$state{$tuple} || {}}; | |
2306 | $RT::Logger->warn( | |
2307 | "Uh-oh, it looks like we somehow missed a right in " | |
2308 | ."ProcessACLs. Here's what was leftover: $missed" | |
2309 | ); | |
2310 | } | |
2311 | } | |
2312 | ||
2313 | return (@results); | |
2314 | } | |
2315 | ||
2316 | ||
2317 | ||
2318 | ||
2319 | =head2 UpdateRecordObj ( ARGSRef => \%ARGS, Object => RT::Record, AttributesRef => \@attribs) | |
2320 | ||
2321 | @attribs is a list of ticket fields to check and update if they differ from the B<Object>'s current values. ARGSRef is a ref to HTML::Mason's %ARGS. | |
2322 | ||
2323 | Returns an array of success/failure messages | |
2324 | ||
2325 | =cut | |
2326 | ||
2327 | sub UpdateRecordObject { | |
2328 | my %args = ( | |
2329 | ARGSRef => undef, | |
2330 | AttributesRef => undef, | |
2331 | Object => undef, | |
2332 | AttributePrefix => undef, | |
2333 | @_ | |
2334 | ); | |
2335 | ||
2336 | my $Object = $args{'Object'}; | |
2337 | my @results = $Object->Update( | |
2338 | AttributesRef => $args{'AttributesRef'}, | |
2339 | ARGSRef => $args{'ARGSRef'}, | |
2340 | AttributePrefix => $args{'AttributePrefix'}, | |
2341 | ); | |
2342 | ||
2343 | return (@results); | |
2344 | } | |
2345 | ||
2346 | ||
2347 | ||
2348 | sub ProcessCustomFieldUpdates { | |
2349 | my %args = ( | |
2350 | CustomFieldObj => undef, | |
2351 | ARGSRef => undef, | |
2352 | @_ | |
2353 | ); | |
2354 | ||
2355 | my $Object = $args{'CustomFieldObj'}; | |
2356 | my $ARGSRef = $args{'ARGSRef'}; | |
2357 | ||
2358 | my @attribs = qw(Name Type Description Queue SortOrder); | |
2359 | my @results = UpdateRecordObject( | |
2360 | AttributesRef => \@attribs, | |
2361 | Object => $Object, | |
2362 | ARGSRef => $ARGSRef | |
2363 | ); | |
2364 | ||
2365 | my $prefix = "CustomField-" . $Object->Id; | |
2366 | if ( $ARGSRef->{"$prefix-AddValue-Name"} ) { | |
2367 | my ( $addval, $addmsg ) = $Object->AddValue( | |
2368 | Name => $ARGSRef->{"$prefix-AddValue-Name"}, | |
2369 | Description => $ARGSRef->{"$prefix-AddValue-Description"}, | |
2370 | SortOrder => $ARGSRef->{"$prefix-AddValue-SortOrder"}, | |
2371 | ); | |
2372 | push( @results, $addmsg ); | |
2373 | } | |
2374 | ||
2375 | my @delete_values | |
2376 | = ( ref $ARGSRef->{"$prefix-DeleteValue"} eq 'ARRAY' ) | |
2377 | ? @{ $ARGSRef->{"$prefix-DeleteValue"} } | |
2378 | : ( $ARGSRef->{"$prefix-DeleteValue"} ); | |
2379 | ||
2380 | foreach my $id (@delete_values) { | |
2381 | next unless defined $id; | |
2382 | my ( $err, $msg ) = $Object->DeleteValue($id); | |
2383 | push( @results, $msg ); | |
2384 | } | |
2385 | ||
2386 | my $vals = $Object->Values(); | |
2387 | while ( my $cfv = $vals->Next() ) { | |
2388 | if ( my $so = $ARGSRef->{ "$prefix-SortOrder" . $cfv->Id } ) { | |
2389 | if ( $cfv->SortOrder != $so ) { | |
2390 | my ( $err, $msg ) = $cfv->SetSortOrder($so); | |
2391 | push( @results, $msg ); | |
2392 | } | |
2393 | } | |
2394 | } | |
2395 | ||
2396 | return (@results); | |
2397 | } | |
2398 | ||
2399 | ||
2400 | ||
2401 | =head2 ProcessTicketBasics ( TicketObj => $Ticket, ARGSRef => \%ARGS ); | |
2402 | ||
2403 | Returns an array of results messages. | |
2404 | ||
2405 | =cut | |
2406 | ||
2407 | sub ProcessTicketBasics { | |
2408 | ||
2409 | my %args = ( | |
2410 | TicketObj => undef, | |
2411 | ARGSRef => undef, | |
2412 | @_ | |
2413 | ); | |
2414 | ||
2415 | my $TicketObj = $args{'TicketObj'}; | |
2416 | my $ARGSRef = $args{'ARGSRef'}; | |
2417 | ||
2418 | my $OrigOwner = $TicketObj->Owner; | |
2419 | ||
2420 | # Set basic fields | |
2421 | my @attribs = qw( | |
2422 | Subject | |
2423 | FinalPriority | |
2424 | Priority | |
2425 | TimeEstimated | |
2426 | TimeWorked | |
2427 | TimeLeft | |
2428 | Type | |
2429 | Status | |
2430 | Queue | |
2431 | ); | |
2432 | ||
2433 | # Canonicalize Queue and Owner to their IDs if they aren't numeric | |
2434 | for my $field (qw(Queue Owner)) { | |
2435 | if ( $ARGSRef->{$field} and ( $ARGSRef->{$field} !~ /^(\d+)$/ ) ) { | |
2436 | my $class = $field eq 'Owner' ? "RT::User" : "RT::$field"; | |
2437 | my $temp = $class->new(RT->SystemUser); | |
2438 | $temp->Load( $ARGSRef->{$field} ); | |
2439 | if ( $temp->id ) { | |
2440 | $ARGSRef->{$field} = $temp->id; | |
2441 | } | |
2442 | } | |
2443 | } | |
2444 | ||
2445 | # Status isn't a field that can be set to a null value. | |
2446 | # RT core complains if you try | |
2447 | delete $ARGSRef->{'Status'} unless $ARGSRef->{'Status'}; | |
2448 | ||
2449 | my @results = UpdateRecordObject( | |
2450 | AttributesRef => \@attribs, | |
2451 | Object => $TicketObj, | |
2452 | ARGSRef => $ARGSRef, | |
2453 | ); | |
2454 | ||
2455 | # We special case owner changing, so we can use ForceOwnerChange | |
2456 | if ( $ARGSRef->{'Owner'} | |
2457 | && $ARGSRef->{'Owner'} !~ /\D/ | |
2458 | && ( $OrigOwner != $ARGSRef->{'Owner'} ) ) { | |
2459 | my ($ChownType); | |
2460 | if ( $ARGSRef->{'ForceOwnerChange'} ) { | |
2461 | $ChownType = "Force"; | |
2462 | } | |
2463 | else { | |
2464 | $ChownType = "Set"; | |
2465 | } | |
2466 | ||
2467 | my ( $val, $msg ) = $TicketObj->SetOwner( $ARGSRef->{'Owner'}, $ChownType ); | |
2468 | push( @results, $msg ); | |
2469 | } | |
2470 | ||
2471 | # }}} | |
2472 | ||
2473 | return (@results); | |
2474 | } | |
2475 | ||
2476 | sub ProcessTicketReminders { | |
2477 | my %args = ( | |
2478 | TicketObj => undef, | |
2479 | ARGSRef => undef, | |
2480 | @_ | |
2481 | ); | |
2482 | ||
2483 | my $Ticket = $args{'TicketObj'}; | |
2484 | my $args = $args{'ARGSRef'}; | |
2485 | my @results; | |
2486 | ||
2487 | my $reminder_collection = $Ticket->Reminders->Collection; | |
2488 | ||
2489 | if ( $args->{'update-reminders'} ) { | |
2490 | while ( my $reminder = $reminder_collection->Next ) { | |
b5747ff2 MKG |
2491 | my $resolve_status = $reminder->QueueObj->Lifecycle->ReminderStatusOnResolve; |
2492 | if ( $reminder->Status ne $resolve_status && $args->{ 'Complete-Reminder-' . $reminder->id } ) { | |
84fb5b46 MKG |
2493 | $Ticket->Reminders->Resolve($reminder); |
2494 | } | |
b5747ff2 | 2495 | elsif ( $reminder->Status eq $resolve_status && !$args->{ 'Complete-Reminder-' . $reminder->id } ) { |
84fb5b46 MKG |
2496 | $Ticket->Reminders->Open($reminder); |
2497 | } | |
2498 | ||
2499 | if ( exists( $args->{ 'Reminder-Subject-' . $reminder->id } ) && ( $reminder->Subject ne $args->{ 'Reminder-Subject-' . $reminder->id } )) { | |
2500 | $reminder->SetSubject( $args->{ 'Reminder-Subject-' . $reminder->id } ) ; | |
2501 | } | |
2502 | ||
2503 | if ( exists( $args->{ 'Reminder-Owner-' . $reminder->id } ) && ( $reminder->Owner != $args->{ 'Reminder-Owner-' . $reminder->id } )) { | |
2504 | $reminder->SetOwner( $args->{ 'Reminder-Owner-' . $reminder->id } , "Force" ) ; | |
2505 | } | |
2506 | ||
2507 | if ( exists( $args->{ 'Reminder-Due-' . $reminder->id } ) && $args->{ 'Reminder-Due-' . $reminder->id } ne '' ) { | |
2508 | my $DateObj = RT::Date->new( $session{'CurrentUser'} ); | |
2509 | $DateObj->Set( | |
2510 | Format => 'unknown', | |
2511 | Value => $args->{ 'Reminder-Due-' . $reminder->id } | |
2512 | ); | |
2513 | if ( defined $DateObj->Unix && $DateObj->Unix != $reminder->DueObj->Unix ) { | |
2514 | $reminder->SetDue( $DateObj->ISO ); | |
2515 | } | |
2516 | } | |
2517 | } | |
2518 | } | |
2519 | ||
2520 | if ( $args->{'NewReminder-Subject'} ) { | |
2521 | my $due_obj = RT::Date->new( $session{'CurrentUser'} ); | |
2522 | $due_obj->Set( | |
2523 | Format => 'unknown', | |
2524 | Value => $args->{'NewReminder-Due'} | |
2525 | ); | |
2526 | my ( $add_id, $msg, $txnid ) = $Ticket->Reminders->Add( | |
2527 | Subject => $args->{'NewReminder-Subject'}, | |
2528 | Owner => $args->{'NewReminder-Owner'}, | |
2529 | Due => $due_obj->ISO | |
2530 | ); | |
2531 | push @results, loc("Reminder '[_1]' added", $args->{'NewReminder-Subject'}); | |
2532 | } | |
2533 | return @results; | |
2534 | } | |
2535 | ||
2536 | sub ProcessTicketCustomFieldUpdates { | |
2537 | my %args = @_; | |
2538 | $args{'Object'} = delete $args{'TicketObj'}; | |
2539 | my $ARGSRef = { %{ $args{'ARGSRef'} } }; | |
2540 | ||
2541 | # Build up a list of objects that we want to work with | |
2542 | my %custom_fields_to_mod; | |
2543 | foreach my $arg ( keys %$ARGSRef ) { | |
2544 | if ( $arg =~ /^Ticket-(\d+-.*)/ ) { | |
2545 | $ARGSRef->{"Object-RT::Ticket-$1"} = delete $ARGSRef->{$arg}; | |
2546 | } elsif ( $arg =~ /^CustomField-(\d+-.*)/ ) { | |
2547 | $ARGSRef->{"Object-RT::Ticket--$1"} = delete $ARGSRef->{$arg}; | |
2548 | } | |
2549 | } | |
2550 | ||
2551 | return ProcessObjectCustomFieldUpdates( %args, ARGSRef => $ARGSRef ); | |
2552 | } | |
2553 | ||
2554 | sub ProcessObjectCustomFieldUpdates { | |
2555 | my %args = @_; | |
2556 | my $ARGSRef = $args{'ARGSRef'}; | |
2557 | my @results; | |
2558 | ||
2559 | # Build up a list of objects that we want to work with | |
2560 | my %custom_fields_to_mod; | |
2561 | foreach my $arg ( keys %$ARGSRef ) { | |
2562 | ||
2563 | # format: Object-<object class>-<object id>-CustomField-<CF id>-<commands> | |
2564 | next unless $arg =~ /^Object-([\w:]+)-(\d*)-CustomField-(\d+)-(.*)$/; | |
2565 | ||
2566 | # For each of those objects, find out what custom fields we want to work with. | |
2567 | $custom_fields_to_mod{$1}{ $2 || 0 }{$3}{$4} = $ARGSRef->{$arg}; | |
2568 | } | |
2569 | ||
2570 | # For each of those objects | |
2571 | foreach my $class ( keys %custom_fields_to_mod ) { | |
2572 | foreach my $id ( keys %{ $custom_fields_to_mod{$class} } ) { | |
2573 | my $Object = $args{'Object'}; | |
2574 | $Object = $class->new( $session{'CurrentUser'} ) | |
2575 | unless $Object && ref $Object eq $class; | |
2576 | ||
2577 | $Object->Load($id) unless ( $Object->id || 0 ) == $id; | |
2578 | unless ( $Object->id ) { | |
2579 | $RT::Logger->warning("Couldn't load object $class #$id"); | |
2580 | next; | |
2581 | } | |
2582 | ||
2583 | foreach my $cf ( keys %{ $custom_fields_to_mod{$class}{$id} } ) { | |
2584 | my $CustomFieldObj = RT::CustomField->new( $session{'CurrentUser'} ); | |
2585 | $CustomFieldObj->SetContextObject($Object); | |
2586 | $CustomFieldObj->LoadById($cf); | |
2587 | unless ( $CustomFieldObj->id ) { | |
2588 | $RT::Logger->warning("Couldn't load custom field #$cf"); | |
2589 | next; | |
2590 | } | |
2591 | push @results, | |
2592 | _ProcessObjectCustomFieldUpdates( | |
2593 | Prefix => "Object-$class-$id-CustomField-$cf-", | |
2594 | Object => $Object, | |
2595 | CustomField => $CustomFieldObj, | |
2596 | ARGS => $custom_fields_to_mod{$class}{$id}{$cf}, | |
2597 | ); | |
2598 | } | |
2599 | } | |
2600 | } | |
2601 | return @results; | |
2602 | } | |
2603 | ||
2604 | sub _ProcessObjectCustomFieldUpdates { | |
2605 | my %args = @_; | |
2606 | my $cf = $args{'CustomField'}; | |
2607 | my $cf_type = $cf->Type || ''; | |
2608 | ||
2609 | # Remove blank Values since the magic field will take care of this. Sometimes | |
2610 | # the browser gives you a blank value which causes CFs to be processed twice | |
2611 | if ( defined $args{'ARGS'}->{'Values'} | |
2612 | && !length $args{'ARGS'}->{'Values'} | |
2613 | && $args{'ARGS'}->{'Values-Magic'} ) | |
2614 | { | |
2615 | delete $args{'ARGS'}->{'Values'}; | |
2616 | } | |
2617 | ||
2618 | my @results; | |
2619 | foreach my $arg ( keys %{ $args{'ARGS'} } ) { | |
2620 | ||
2621 | # skip category argument | |
2622 | next if $arg eq 'Category'; | |
2623 | ||
2624 | # since http won't pass in a form element with a null value, we need | |
2625 | # to fake it | |
2626 | if ( $arg eq 'Values-Magic' ) { | |
2627 | ||
2628 | # We don't care about the magic, if there's really a values element; | |
2629 | next if defined $args{'ARGS'}->{'Value'} && length $args{'ARGS'}->{'Value'}; | |
2630 | next if defined $args{'ARGS'}->{'Values'} && length $args{'ARGS'}->{'Values'}; | |
2631 | ||
2632 | # "Empty" values does not mean anything for Image and Binary fields | |
2633 | next if $cf_type =~ /^(?:Image|Binary)$/; | |
2634 | ||
2635 | $arg = 'Values'; | |
2636 | $args{'ARGS'}->{'Values'} = undef; | |
2637 | } | |
2638 | ||
2639 | my @values = (); | |
2640 | if ( ref $args{'ARGS'}->{$arg} eq 'ARRAY' ) { | |
2641 | @values = @{ $args{'ARGS'}->{$arg} }; | |
2642 | } elsif ( $cf_type =~ /text/i ) { # Both Text and Wikitext | |
2643 | @values = ( $args{'ARGS'}->{$arg} ); | |
2644 | } else { | |
2645 | @values = split /\r*\n/, $args{'ARGS'}->{$arg} | |
2646 | if defined $args{'ARGS'}->{$arg}; | |
2647 | } | |
2648 | @values = grep length, map { | |
2649 | s/\r+\n/\n/g; | |
2650 | s/^\s+//; | |
2651 | s/\s+$//; | |
2652 | $_; | |
2653 | } | |
2654 | grep defined, @values; | |
2655 | ||
2656 | if ( $arg eq 'AddValue' || $arg eq 'Value' ) { | |
2657 | foreach my $value (@values) { | |
2658 | my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( | |
2659 | Field => $cf->id, | |
2660 | Value => $value | |
2661 | ); | |
2662 | push( @results, $msg ); | |
2663 | } | |
2664 | } elsif ( $arg eq 'Upload' ) { | |
2665 | my $value_hash = _UploadedFile( $args{'Prefix'} . $arg ) or next; | |
2666 | my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( %$value_hash, Field => $cf, ); | |
2667 | push( @results, $msg ); | |
2668 | } elsif ( $arg eq 'DeleteValues' ) { | |
2669 | foreach my $value (@values) { | |
2670 | my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( | |
2671 | Field => $cf, | |
2672 | Value => $value, | |
2673 | ); | |
2674 | push( @results, $msg ); | |
2675 | } | |
2676 | } elsif ( $arg eq 'DeleteValueIds' ) { | |
2677 | foreach my $value (@values) { | |
2678 | my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( | |
2679 | Field => $cf, | |
2680 | ValueId => $value, | |
2681 | ); | |
2682 | push( @results, $msg ); | |
2683 | } | |
2684 | } elsif ( $arg eq 'Values' && !$cf->Repeated ) { | |
2685 | my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); | |
2686 | ||
2687 | my %values_hash; | |
2688 | foreach my $value (@values) { | |
2689 | if ( my $entry = $cf_values->HasEntry($value) ) { | |
2690 | $values_hash{ $entry->id } = 1; | |
2691 | next; | |
2692 | } | |
2693 | ||
2694 | my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( | |
2695 | Field => $cf, | |
2696 | Value => $value | |
2697 | ); | |
2698 | push( @results, $msg ); | |
2699 | $values_hash{$val} = 1 if $val; | |
2700 | } | |
2701 | ||
2702 | # For Date Cfs, @values is empty when there is no changes (no datas in form input) | |
2703 | return @results if ( $cf->Type =~ /^Date(?:Time)?$/ && ! @values ); | |
2704 | ||
2705 | $cf_values->RedoSearch; | |
2706 | while ( my $cf_value = $cf_values->Next ) { | |
2707 | next if $values_hash{ $cf_value->id }; | |
2708 | ||
2709 | my ( $val, $msg ) = $args{'Object'}->DeleteCustomFieldValue( | |
2710 | Field => $cf, | |
2711 | ValueId => $cf_value->id | |
2712 | ); | |
2713 | push( @results, $msg ); | |
2714 | } | |
2715 | } elsif ( $arg eq 'Values' ) { | |
2716 | my $cf_values = $args{'Object'}->CustomFieldValues( $cf->id ); | |
2717 | ||
2718 | # keep everything up to the point of difference, delete the rest | |
2719 | my $delete_flag; | |
2720 | foreach my $old_cf ( @{ $cf_values->ItemsArrayRef } ) { | |
2721 | if ( !$delete_flag and @values and $old_cf->Content eq $values[0] ) { | |
2722 | shift @values; | |
2723 | next; | |
2724 | } | |
2725 | ||
2726 | $delete_flag ||= 1; | |
2727 | $old_cf->Delete; | |
2728 | } | |
2729 | ||
2730 | # now add/replace extra things, if any | |
2731 | foreach my $value (@values) { | |
2732 | my ( $val, $msg ) = $args{'Object'}->AddCustomFieldValue( | |
2733 | Field => $cf, | |
2734 | Value => $value | |
2735 | ); | |
2736 | push( @results, $msg ); | |
2737 | } | |
2738 | } else { | |
2739 | push( | |
2740 | @results, | |
2741 | loc("User asked for an unknown update type for custom field [_1] for [_2] object #[_3]", | |
2742 | $cf->Name, ref $args{'Object'}, | |
2743 | $args{'Object'}->id | |
2744 | ) | |
2745 | ); | |
2746 | } | |
2747 | } | |
2748 | return @results; | |
2749 | } | |
2750 | ||
2751 | ||
2752 | =head2 ProcessTicketWatchers ( TicketObj => $Ticket, ARGSRef => \%ARGS ); | |
2753 | ||
2754 | Returns an array of results messages. | |
2755 | ||
2756 | =cut | |
2757 | ||
2758 | sub ProcessTicketWatchers { | |
2759 | my %args = ( | |
2760 | TicketObj => undef, | |
2761 | ARGSRef => undef, | |
2762 | @_ | |
2763 | ); | |
2764 | my (@results); | |
2765 | ||
2766 | my $Ticket = $args{'TicketObj'}; | |
2767 | my $ARGSRef = $args{'ARGSRef'}; | |
2768 | ||
2769 | # Munge watchers | |
2770 | ||
2771 | foreach my $key ( keys %$ARGSRef ) { | |
2772 | ||
2773 | # Delete deletable watchers | |
2774 | if ( $key =~ /^Ticket-DeleteWatcher-Type-(.*)-Principal-(\d+)$/ ) { | |
2775 | my ( $code, $msg ) = $Ticket->DeleteWatcher( | |
2776 | PrincipalId => $2, | |
2777 | Type => $1 | |
2778 | ); | |
2779 | push @results, $msg; | |
2780 | } | |
2781 | ||
2782 | # Delete watchers in the simple style demanded by the bulk manipulator | |
2783 | elsif ( $key =~ /^Delete(Requestor|Cc|AdminCc)$/ ) { | |
2784 | my ( $code, $msg ) = $Ticket->DeleteWatcher( | |
2785 | Email => $ARGSRef->{$key}, | |
2786 | Type => $1 | |
2787 | ); | |
2788 | push @results, $msg; | |
2789 | } | |
2790 | ||
2791 | # Add new wathchers by email address | |
2792 | elsif ( ( $ARGSRef->{$key} || '' ) =~ /^(?:AdminCc|Cc|Requestor)$/ | |
2793 | and $key =~ /^WatcherTypeEmail(\d*)$/ ) | |
2794 | { | |
2795 | ||
2796 | #They're in this order because otherwise $1 gets clobbered :/ | |
2797 | my ( $code, $msg ) = $Ticket->AddWatcher( | |
2798 | Type => $ARGSRef->{$key}, | |
2799 | Email => $ARGSRef->{ "WatcherAddressEmail" . $1 } | |
2800 | ); | |
2801 | push @results, $msg; | |
2802 | } | |
2803 | ||
2804 | #Add requestors in the simple style demanded by the bulk manipulator | |
2805 | elsif ( $key =~ /^Add(Requestor|Cc|AdminCc)$/ ) { | |
2806 | my ( $code, $msg ) = $Ticket->AddWatcher( | |
2807 | Type => $1, | |
2808 | Email => $ARGSRef->{$key} | |
2809 | ); | |
2810 | push @results, $msg; | |
2811 | } | |
2812 | ||
2813 | # Add new watchers by owner | |
2814 | elsif ( $key =~ /^Ticket-AddWatcher-Principal-(\d*)$/ ) { | |
2815 | my $principal_id = $1; | |
2816 | my $form = $ARGSRef->{$key}; | |
2817 | foreach my $value ( ref($form) ? @{$form} : ($form) ) { | |
2818 | next unless $value =~ /^(?:AdminCc|Cc|Requestor)$/i; | |
2819 | ||
2820 | my ( $code, $msg ) = $Ticket->AddWatcher( | |
2821 | Type => $value, | |
2822 | PrincipalId => $principal_id | |
2823 | ); | |
2824 | push @results, $msg; | |
2825 | } | |
2826 | } | |
2827 | ||
2828 | } | |
2829 | return (@results); | |
2830 | } | |
2831 | ||
2832 | ||
2833 | ||
2834 | =head2 ProcessTicketDates ( TicketObj => $Ticket, ARGSRef => \%ARGS ); | |
2835 | ||
2836 | Returns an array of results messages. | |
2837 | ||
2838 | =cut | |
2839 | ||
2840 | sub ProcessTicketDates { | |
2841 | my %args = ( | |
2842 | TicketObj => undef, | |
2843 | ARGSRef => undef, | |
2844 | @_ | |
2845 | ); | |
2846 | ||
2847 | my $Ticket = $args{'TicketObj'}; | |
2848 | my $ARGSRef = $args{'ARGSRef'}; | |
2849 | ||
2850 | my (@results); | |
2851 | ||
2852 | # Set date fields | |
2853 | my @date_fields = qw( | |
2854 | Told | |
2855 | Resolved | |
2856 | Starts | |
2857 | Started | |
2858 | Due | |
2859 | ); | |
2860 | ||
2861 | #Run through each field in this list. update the value if apropriate | |
2862 | foreach my $field (@date_fields) { | |
2863 | next unless exists $ARGSRef->{ $field . '_Date' }; | |
2864 | next if $ARGSRef->{ $field . '_Date' } eq ''; | |
2865 | ||
2866 | my ( $code, $msg ); | |
2867 | ||
2868 | my $DateObj = RT::Date->new( $session{'CurrentUser'} ); | |
2869 | $DateObj->Set( | |
2870 | Format => 'unknown', | |
2871 | Value => $ARGSRef->{ $field . '_Date' } | |
2872 | ); | |
2873 | ||
2874 | my $obj = $field . "Obj"; | |
2875 | if ( ( defined $DateObj->Unix ) | |
2876 | and ( $DateObj->Unix != $Ticket->$obj()->Unix() ) ) | |
2877 | { | |
2878 | my $method = "Set$field"; | |
2879 | my ( $code, $msg ) = $Ticket->$method( $DateObj->ISO ); | |
2880 | push @results, "$msg"; | |
2881 | } | |
2882 | } | |
2883 | ||
2884 | # }}} | |
2885 | return (@results); | |
2886 | } | |
2887 | ||
2888 | ||
2889 | ||
2890 | =head2 ProcessTicketLinks ( TicketObj => $Ticket, ARGSRef => \%ARGS ); | |
2891 | ||
2892 | Returns an array of results messages. | |
2893 | ||
2894 | =cut | |
2895 | ||
2896 | sub ProcessTicketLinks { | |
2897 | my %args = ( | |
2898 | TicketObj => undef, | |
2899 | ARGSRef => undef, | |
2900 | @_ | |
2901 | ); | |
2902 | ||
2903 | my $Ticket = $args{'TicketObj'}; | |
2904 | my $ARGSRef = $args{'ARGSRef'}; | |
2905 | ||
2906 | my (@results) = ProcessRecordLinks( RecordObj => $Ticket, ARGSRef => $ARGSRef ); | |
2907 | ||
2908 | #Merge if we need to | |
2909 | if ( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ) { | |
2910 | $ARGSRef->{ $Ticket->Id . "-MergeInto" } =~ s/\s+//g; | |
2911 | my ( $val, $msg ) = $Ticket->MergeInto( $ARGSRef->{ $Ticket->Id . "-MergeInto" } ); | |
2912 | push @results, $msg; | |
2913 | } | |
2914 | ||
2915 | return (@results); | |
2916 | } | |
2917 | ||
2918 | ||
2919 | sub ProcessRecordLinks { | |
2920 | my %args = ( | |
2921 | RecordObj => undef, | |
2922 | ARGSRef => undef, | |
2923 | @_ | |
2924 | ); | |
2925 | ||
2926 | my $Record = $args{'RecordObj'}; | |
2927 | my $ARGSRef = $args{'ARGSRef'}; | |
2928 | ||
2929 | my (@results); | |
2930 | ||
2931 | # Delete links that are gone gone gone. | |
2932 | foreach my $arg ( keys %$ARGSRef ) { | |
2933 | if ( $arg =~ /DeleteLink-(.*?)-(DependsOn|MemberOf|RefersTo)-(.*)$/ ) { | |
2934 | my $base = $1; | |
2935 | my $type = $2; | |
2936 | my $target = $3; | |
2937 | ||
2938 | my ( $val, $msg ) = $Record->DeleteLink( | |
2939 | Base => $base, | |
2940 | Type => $type, | |
2941 | Target => $target | |
2942 | ); | |
2943 | ||
2944 | push @results, $msg; | |
2945 | ||
2946 | } | |
2947 | ||
2948 | } | |
2949 | ||
2950 | my @linktypes = qw( DependsOn MemberOf RefersTo ); | |
2951 | ||
2952 | foreach my $linktype (@linktypes) { | |
2953 | if ( $ARGSRef->{ $Record->Id . "-$linktype" } ) { | |
2954 | $ARGSRef->{ $Record->Id . "-$linktype" } = join( ' ', @{ $ARGSRef->{ $Record->Id . "-$linktype" } } ) | |
2955 | if ref( $ARGSRef->{ $Record->Id . "-$linktype" } ); | |
2956 | ||
2957 | for my $luri ( split( / /, $ARGSRef->{ $Record->Id . "-$linktype" } ) ) { | |
2958 | next unless $luri; | |
2959 | $luri =~ s/\s+$//; # Strip trailing whitespace | |
2960 | my ( $val, $msg ) = $Record->AddLink( | |
2961 | Target => $luri, | |
2962 | Type => $linktype | |
2963 | ); | |
2964 | push @results, $msg; | |
2965 | } | |
2966 | } | |
2967 | if ( $ARGSRef->{ "$linktype-" . $Record->Id } ) { | |
2968 | $ARGSRef->{ "$linktype-" . $Record->Id } = join( ' ', @{ $ARGSRef->{ "$linktype-" . $Record->Id } } ) | |
2969 | if ref( $ARGSRef->{ "$linktype-" . $Record->Id } ); | |
2970 | ||
2971 | for my $luri ( split( / /, $ARGSRef->{ "$linktype-" . $Record->Id } ) ) { | |
2972 | next unless $luri; | |
2973 | my ( $val, $msg ) = $Record->AddLink( | |
2974 | Base => $luri, | |
2975 | Type => $linktype | |
2976 | ); | |
2977 | ||
2978 | push @results, $msg; | |
2979 | } | |
2980 | } | |
2981 | } | |
2982 | ||
2983 | return (@results); | |
2984 | } | |
2985 | ||
2986 | =head2 _UploadedFile ( $arg ); | |
2987 | ||
2988 | Takes a CGI parameter name; if a file is uploaded under that name, | |
2989 | return a hash reference suitable for AddCustomFieldValue's use: | |
2990 | C<( Value => $filename, LargeContent => $content, ContentType => $type )>. | |
2991 | ||
2992 | Returns C<undef> if no files were uploaded in the C<$arg> field. | |
2993 | ||
2994 | =cut | |
2995 | ||
2996 | sub _UploadedFile { | |
2997 | my $arg = shift; | |
2998 | my $cgi_object = $m->cgi_object; | |
2999 | my $fh = $cgi_object->upload($arg) or return undef; | |
3000 | my $upload_info = $cgi_object->uploadInfo($fh); | |
3001 | ||
3002 | my $filename = "$fh"; | |
3003 | $filename =~ s#^.*[\\/]##; | |
3004 | binmode($fh); | |
3005 | ||
3006 | return { | |
3007 | Value => $filename, | |
3008 | LargeContent => do { local $/; scalar <$fh> }, | |
3009 | ContentType => $upload_info->{'Content-Type'}, | |
3010 | }; | |
3011 | } | |
3012 | ||
3013 | sub GetColumnMapEntry { | |
3014 | my %args = ( Map => {}, Name => '', Attribute => undef, @_ ); | |
3015 | ||
3016 | # deal with the simplest thing first | |
3017 | if ( $args{'Map'}{ $args{'Name'} } ) { | |
3018 | return $args{'Map'}{ $args{'Name'} }{ $args{'Attribute'} }; | |
3019 | } | |
3020 | ||
3021 | # complex things | |
3022 | elsif ( my ( $mainkey, $subkey ) = $args{'Name'} =~ /^(.*?)\.{(.+)}$/ ) { | |
3023 | return undef unless $args{'Map'}->{$mainkey}; | |
3024 | return $args{'Map'}{$mainkey}{ $args{'Attribute'} } | |
3025 | unless ref $args{'Map'}{$mainkey}{ $args{'Attribute'} } eq 'CODE'; | |
3026 | ||
3027 | return sub { $args{'Map'}{$mainkey}{ $args{'Attribute'} }->( @_, $subkey ) }; | |
3028 | } | |
3029 | return undef; | |
3030 | } | |
3031 | ||
3032 | sub ProcessColumnMapValue { | |
3033 | my $value = shift; | |
3034 | my %args = ( Arguments => [], Escape => 1, @_ ); | |
3035 | ||
3036 | if ( ref $value ) { | |
3037 | if ( UNIVERSAL::isa( $value, 'CODE' ) ) { | |
3038 | my @tmp = $value->( @{ $args{'Arguments'} } ); | |
3039 | return ProcessColumnMapValue( ( @tmp > 1 ? \@tmp : $tmp[0] ), %args ); | |
3040 | } elsif ( UNIVERSAL::isa( $value, 'ARRAY' ) ) { | |
3041 | return join '', map ProcessColumnMapValue( $_, %args ), @$value; | |
3042 | } elsif ( UNIVERSAL::isa( $value, 'SCALAR' ) ) { | |
3043 | return $$value; | |
3044 | } | |
3045 | } | |
3046 | ||
3047 | return $m->interp->apply_escapes( $value, 'h' ) if $args{'Escape'}; | |
3048 | return $value; | |
3049 | } | |
3050 | ||
3051 | =head2 GetPrincipalsMap OBJECT, CATEGORIES | |
3052 | ||
3053 | Returns an array suitable for passing to /Admin/Elements/EditRights with the | |
3054 | principal collections mapped from the categories given. | |
3055 | ||
3056 | =cut | |
3057 | ||
3058 | sub GetPrincipalsMap { | |
3059 | my $object = shift; | |
3060 | my @map; | |
3061 | for (@_) { | |
3062 | if (/System/) { | |
3063 | my $system = RT::Groups->new($session{'CurrentUser'}); | |
3064 | $system->LimitToSystemInternalGroups(); | |
3065 | $system->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); | |
3066 | push @map, [ | |
3067 | 'System' => $system, # loc_left_pair | |
3068 | 'Type' => 1, | |
3069 | ]; | |
3070 | } | |
3071 | elsif (/Groups/) { | |
3072 | my $groups = RT::Groups->new($session{'CurrentUser'}); | |
3073 | $groups->LimitToUserDefinedGroups(); | |
3074 | $groups->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); | |
3075 | ||
3076 | # Only show groups who have rights granted on this object | |
3077 | $groups->WithGroupRight( | |
3078 | Right => '', | |
3079 | Object => $object, | |
3080 | IncludeSystemRights => 0, | |
3081 | IncludeSubgroupMembers => 0, | |
3082 | ); | |
3083 | ||
3084 | push @map, [ | |
3085 | 'User Groups' => $groups, # loc_left_pair | |
3086 | 'Name' => 0 | |
3087 | ]; | |
3088 | } | |
3089 | elsif (/Roles/) { | |
3090 | my $roles = RT::Groups->new($session{'CurrentUser'}); | |
3091 | ||
3092 | if ($object->isa('RT::System')) { | |
3093 | $roles->LimitToRolesForSystem(); | |
3094 | } | |
3095 | elsif ($object->isa('RT::Queue')) { | |
3096 | $roles->LimitToRolesForQueue($object->Id); | |
3097 | } | |
3098 | else { | |
3099 | $RT::Logger->warn("Skipping unknown object type ($object) for Role principals"); | |
3100 | next; | |
3101 | } | |
3102 | $roles->OrderBy( FIELD => 'Type', ORDER => 'ASC' ); | |
3103 | push @map, [ | |
3104 | 'Roles' => $roles, # loc_left_pair | |
3105 | 'Type' => 1 | |
3106 | ]; | |
3107 | } | |
3108 | elsif (/Users/) { | |
3109 | my $Users = RT->PrivilegedUsers->UserMembersObj(); | |
3110 | $Users->OrderBy( FIELD => 'Name', ORDER => 'ASC' ); | |
3111 | ||
3112 | # Only show users who have rights granted on this object | |
3113 | my $group_members = $Users->WhoHaveGroupRight( | |
3114 | Right => '', | |
3115 | Object => $object, | |
3116 | IncludeSystemRights => 0, | |
3117 | IncludeSubgroupMembers => 0, | |
3118 | ); | |
3119 | ||
3120 | # Limit to UserEquiv groups | |
3121 | my $groups = $Users->NewAlias('Groups'); | |
3122 | $Users->Join( | |
3123 | ALIAS1 => $groups, | |
3124 | FIELD1 => 'id', | |
3125 | ALIAS2 => $group_members, | |
3126 | FIELD2 => 'GroupId' | |
3127 | ); | |
3128 | $Users->Limit( ALIAS => $groups, FIELD => 'Domain', VALUE => 'ACLEquivalence' ); | |
3129 | $Users->Limit( ALIAS => $groups, FIELD => 'Type', VALUE => 'UserEquiv' ); | |
3130 | ||
3131 | ||
3132 | my $display = sub { | |
3133 | $m->scomp('/Elements/ShowUser', User => $_[0], NoEscape => 1) | |
3134 | }; | |
3135 | push @map, [ | |
3136 | 'Users' => $Users, # loc_left_pair | |
3137 | $display => 0 | |
3138 | ]; | |
3139 | } | |
3140 | } | |
3141 | return @map; | |
3142 | } | |
3143 | ||
3144 | =head2 _load_container_object ( $type, $id ); | |
3145 | ||
3146 | Instantiate container object for saving searches. | |
3147 | ||
3148 | =cut | |
3149 | ||
3150 | sub _load_container_object { | |
3151 | my ( $obj_type, $obj_id ) = @_; | |
3152 | return RT::SavedSearch->new( $session{'CurrentUser'} )->_load_privacy_object( $obj_type, $obj_id ); | |
3153 | } | |
3154 | ||
3155 | =head2 _parse_saved_search ( $arg ); | |
3156 | ||
3157 | Given a serialization string for saved search, and returns the | |
3158 | container object and the search id. | |
3159 | ||
3160 | =cut | |
3161 | ||
3162 | sub _parse_saved_search { | |
3163 | my $spec = shift; | |
3164 | return unless $spec; | |
3165 | if ( $spec !~ /^(.*?)-(\d+)-SavedSearch-(\d+)$/ ) { | |
3166 | return; | |
3167 | } | |
3168 | my $obj_type = $1; | |
3169 | my $obj_id = $2; | |
3170 | my $search_id = $3; | |
3171 | ||
3172 | return ( _load_container_object( $obj_type, $obj_id ), $search_id ); | |
3173 | } | |
3174 | ||
3175 | =head2 ScrubHTML content | |
3176 | ||
3177 | Removes unsafe and undesired HTML from the passed content | |
3178 | ||
3179 | =cut | |
3180 | ||
3181 | my $SCRUBBER; | |
3182 | sub ScrubHTML { | |
3183 | my $Content = shift; | |
3184 | $SCRUBBER = _NewScrubber() unless $SCRUBBER; | |
3185 | ||
3186 | $Content = '' if !defined($Content); | |
3187 | return $SCRUBBER->scrub($Content); | |
3188 | } | |
3189 | ||
3190 | =head2 _NewScrubber | |
3191 | ||
3192 | Returns a new L<HTML::Scrubber> object. | |
3193 | ||
3194 | If you need to be more lax about what HTML tags and attributes are allowed, | |
3195 | create C</opt/rt4/local/lib/RT/Interface/Web_Local.pm> with something like the | |
3196 | following: | |
3197 | ||
3198 | package HTML::Mason::Commands; | |
3199 | # Let tables through | |
3200 | push @SCRUBBER_ALLOWED_TAGS, qw(TABLE THEAD TBODY TFOOT TR TD TH); | |
3201 | 1; | |
3202 | ||
3203 | =cut | |
3204 | ||
3205 | our @SCRUBBER_ALLOWED_TAGS = qw( | |
3206 | A B U P BR I HR BR SMALL EM FONT SPAN STRONG SUB SUP STRIKE H1 H2 H3 H4 H5 | |
b5747ff2 | 3207 | H6 DIV UL OL LI DL DT DD PRE BLOCKQUOTE BDO |
84fb5b46 MKG |
3208 | ); |
3209 | ||
3210 | our %SCRUBBER_ALLOWED_ATTRIBUTES = ( | |
3211 | # Match http, ftp and relative urls | |
3212 | # XXX: we also scrub format strings with this module then allow simple config options | |
3213 | href => qr{^(?:http:|ftp:|https:|/|__Web(?:Path|BaseURL|URL)__)}i, | |
3214 | face => 1, | |
3215 | size => 1, | |
3216 | target => 1, | |
3217 | style => qr{ | |
3218 | ^(?:\s* | |
3219 | (?:(?:background-)?color: \s* | |
3220 | (?:rgb\(\s* \d+, \s* \d+, \s* \d+ \s*\) | # rgb(d,d,d) | |
3221 | \#[a-f0-9]{3,6} | # #fff or #ffffff | |
3222 | [\w\-]+ # green, light-blue, etc. | |
3223 | ) | | |
3224 | text-align: \s* \w+ | | |
3225 | font-size: \s* [\w.\-]+ | | |
3226 | font-family: \s* [\w\s"',.\-]+ | | |
3227 | font-weight: \s* [\w\-]+ | | |
3228 | ||
3229 | # MS Office styles, which are probably fine. If we don't, then any | |
3230 | # associated styles in the same attribute get stripped. | |
3231 | mso-[\w\-]+?: \s* [\w\s"',.\-]+ | |
3232 | )\s* ;? \s*) | |
3233 | +$ # one or more of these allowed properties from here 'till sunset | |
3234 | }ix, | |
b5747ff2 MKG |
3235 | dir => qr/^(rtl|ltr)$/i, |
3236 | lang => qr/^\w+(-\w+)?$/, | |
84fb5b46 MKG |
3237 | ); |
3238 | ||
3239 | our %SCRUBBER_RULES = (); | |
3240 | ||
3241 | sub _NewScrubber { | |
3242 | require HTML::Scrubber; | |
3243 | my $scrubber = HTML::Scrubber->new(); | |
3244 | $scrubber->default( | |
3245 | 0, | |
3246 | { | |
3247 | %SCRUBBER_ALLOWED_ATTRIBUTES, | |
3248 | '*' => 0, # require attributes be explicitly allowed | |
3249 | }, | |
3250 | ); | |
3251 | $scrubber->deny(qw[*]); | |
3252 | $scrubber->allow(@SCRUBBER_ALLOWED_TAGS); | |
3253 | $scrubber->rules(%SCRUBBER_RULES); | |
3254 | ||
3255 | # Scrubbing comments is vital since IE conditional comments can contain | |
3256 | # arbitrary HTML and we'd pass it right on through. | |
3257 | $scrubber->comment(0); | |
3258 | ||
3259 | return $scrubber; | |
3260 | } | |
3261 | ||
3262 | =head2 JSON | |
3263 | ||
3264 | Redispatches to L<RT::Interface::Web/EncodeJSON> | |
3265 | ||
3266 | =cut | |
3267 | ||
3268 | sub JSON { | |
3269 | RT::Interface::Web::EncodeJSON(@_); | |
3270 | } | |
3271 | ||
3272 | package RT::Interface::Web; | |
3273 | RT::Base->_ImportOverlays(); | |
3274 | ||
3275 | 1; |