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