Upgrade to 4.0.10.
[usit-rt.git] / lib / RT / CurrentUser.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 =head1 NAME
50
51   RT::CurrentUser - an RT object representing the current user
52
53 =head1 SYNOPSIS
54
55     use RT::CurrentUser;
56
57     # laod
58     my $current_user = RT::CurrentUser->new;
59     $current_user->Load(...);
60     # or
61     my $current_user = RT::CurrentUser->new( $user_obj );
62     # or
63     my $current_user = RT::CurrentUser->new( $address || $name || $id );
64
65     # manipulation
66     $current_user->UserObj->SetName('new_name');
67
68
69 =head1 DESCRIPTION
70
71 B<Read-only> subclass of L<RT::User> class. Used to define the current
72 user. You should pass an instance of this class to constructors of
73 many RT classes, then the instance used to check ACLs and localize
74 strings.
75
76 =head1 METHODS
77
78 See also L<RT::User> for a list of methods this class has.
79
80 =head2 new
81
82 Returns new CurrentUser object. Unlike all other classes of RT it takes
83 either subclass of C<RT::User> class object or scalar value that is
84 passed to Load method.
85
86 =cut
87
88
89 package RT::CurrentUser;
90
91 use RT::I18N;
92
93 use strict;
94 use warnings;
95
96
97 use base qw/RT::User/;
98
99 #The basic idea here is that $self->CurrentUser is always supposed
100 # to be a CurrentUser object. but that's hard to do when we're trying to load
101 # the CurrentUser object
102
103 sub _Init {
104     my $self = shift;
105     my $User = shift;
106
107     $self->{'table'} = "Users";
108
109     if ( defined $User ) {
110
111         if ( UNIVERSAL::isa( $User, 'RT::User' ) ) {
112             $self->LoadById( $User->id );
113         }
114         elsif ( ref $User ) {
115             $RT::Logger->crit(
116                 "RT::CurrentUser->new() called with a bogus argument: $User");
117         }
118         else {
119             $self->Load( $User );
120         }
121     }
122
123     $self->_BuildTableAttributes;
124
125 }
126
127 =head2 Create, Delete and Set*
128
129 As stated above it's a subclass of L<RT::User>, but this class is read-only
130 and calls to these methods are illegal. Return 'permission denied' message
131 and log an error.
132
133 =cut
134
135 sub Create {
136     my $self = shift;
137     $RT::Logger->error('RT::CurrentUser is read-only, RT::User for manipulation');
138     return (0, $self->loc('Permission Denied'));
139 }
140
141 sub Delete {
142     my $self = shift;
143     $RT::Logger->error('RT::CurrentUser is read-only, RT::User for manipulation');
144     return (0, $self->loc('Permission Denied'));
145 }
146
147 sub _Set {
148     my $self = shift;
149     $RT::Logger->error('RT::CurrentUser is read-only, RT::User for manipulation');
150     return (0, $self->loc('Permission Denied'));
151 }
152
153 =head2 UserObj
154
155 Returns the L<RT::User> object associated with this CurrentUser object.
156
157 =cut
158
159 sub UserObj {
160     my $self = shift;
161
162     my $user = RT::User->new( $self );
163     unless ( $user->LoadById( $self->Id ) ) {
164         $RT::Logger->error("Couldn't load " . $self->Id . " from the users database.");
165     }
166     return $user;
167 }
168
169 sub _CoreAccessible  {
170      {
171          Name           => { 'read' => 1 },
172            Gecos        => { 'read' => 1 },
173            RealName     => { 'read' => 1 },
174            Lang     => { 'read' => 1 },
175            Password     => { 'read' => 0, 'write' => 0 },
176           EmailAddress => { 'read' => 1, 'write' => 0 }
177      };
178   
179 }
180
181 =head2 LoadByGecos
182
183 Loads a User into this CurrentUser object.
184 Takes a unix username as its only argument.
185
186 =cut
187
188 sub LoadByGecos  {
189     my $self = shift;
190     return $self->LoadByCol( "Gecos", shift );
191 }
192
193 =head2 LoadByName
194
195 Loads a User into this CurrentUser object.
196 Takes a Name.
197
198 =cut
199
200 sub LoadByName {
201     my $self = shift;
202     return $self->LoadByCol( "Name", shift );
203 }
204
205 =head2 LanguageHandle
206
207 Returns this current user's langauge handle. Should take a language
208 specification. but currently doesn't
209
210 =cut 
211
212 sub LanguageHandle {
213     my $self = shift;
214     if (   !defined $self->{'LangHandle'}
215         || !UNIVERSAL::can( $self->{'LangHandle'}, 'maketext' )
216         || @_ )
217     {
218         if ( my $lang = $self->Lang ) {
219             push @_, $lang;
220         }
221         elsif ( $self->id && ($self->id == (RT->SystemUser->id||0) || $self->id == (RT->Nobody->id||0)) ) {
222             # don't use ENV magic for system users
223             push @_, 'en';
224         }
225
226         $self->{'LangHandle'} = RT::I18N->get_handle(@_);
227     }
228
229     # Fall back to english.
230     unless ( $self->{'LangHandle'} ) {
231         die "We couldn't get a dictionary. Ne mogu naidti slovar. No puedo encontrar dictionario.";
232     }
233     return $self->{'LangHandle'};
234 }
235
236 sub loc {
237     my $self = shift;
238     return '' if !defined $_[0] || $_[0] eq '';
239
240     my $handle = $self->LanguageHandle;
241
242     if (@_ == 1) {
243         # If we have no [_1] replacements, and the key does not appear
244         # in the lexicon, unescape (using ~) and return it verbatim, as
245         # an optimization.
246         my $unescaped = $_[0];
247         $unescaped =~ s!~(.)!$1!g;
248         return $unescaped unless grep exists $_->{$_[0]}, @{ $handle->_lex_refs };
249     }
250
251     return $handle->maketext(@_);
252 }
253
254 sub loc_fuzzy {
255     my $self = shift;
256     return '' if !defined $_[0] || $_[0] eq '';
257
258     # XXX: work around perl's deficiency when matching utf8 data
259     return $_[0] if Encode::is_utf8($_[0]);
260
261     return $self->LanguageHandle->maketext_fuzzy( @_ );
262 }
263
264 =head2 CurrentUser
265
266 Return the current currentuser object
267
268 =cut
269
270 sub CurrentUser {
271     return shift;
272 }
273
274 =head2 Authenticate
275
276 Takes $password, $created and $nonce, and returns a boolean value
277 representing whether the authentication succeeded.
278
279 If both $nonce and $created are specified, validate $password against:
280
281     encode_base64(sha1(
282         $nonce .
283         $created .
284         sha1_hex( "$username:$realm:$server_pass" )
285     ))
286
287 where $server_pass is the md5_hex(password) digest stored in the
288 database, $created is in ISO time format, and $nonce is a random
289 string no longer than 32 bytes.
290
291 =cut
292
293 sub Authenticate { 
294     my ($self, $password, $created, $nonce, $realm) = @_;
295
296     require Digest::MD5;
297     require Digest::SHA1;
298     require MIME::Base64;
299
300     my $username = $self->UserObj->Name or return;
301     my $server_pass = $self->UserObj->__Value('Password') or return;
302     my $auth_digest = MIME::Base64::encode_base64(Digest::SHA1::sha1(
303         $nonce .
304         $created .
305         Digest::MD5::md5_hex("$username:$realm:$server_pass")
306     ));
307
308     chomp($password);
309     chomp($auth_digest);
310
311     return ($password eq $auth_digest);
312 }
313
314 RT::Base->_ImportOverlays();
315
316 1;