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