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