source: server/trunk/web/lib/Sophie/Controller/User.pm @ 421

Last change on this file since 421 was 421, checked in by nanardon, 12 years ago
  • don't use obsoleted syntax
File size: 3.8 KB
Line 
1package Sophie::Controller::User;
2use Moose;
3use namespace::autoclean;
4use MIME::Base64;
5use Storable qw/nfreeze thaw/;
6use YAML;
7
8BEGIN {extends 'Catalyst::Controller'; }
9
10=head1 NAME
11
12Sophie::Controller::User - Catalyst Controller
13
14=head1 DESCRIPTION
15
16Catalyst Controller.
17
18=head1 METHODS
19
20=cut
21
22
23=head2 index
24
25=cut
26
27sub index :Path :Args(0) {
28    my ( $self, $c ) = @_;
29
30    $c->response->body('Matched Sophie::Controller::User in User.');
31}
32
33sub session : XMLRPC {
34    my ( $self, $c ) = @_;
35
36    $c->session;
37    $c->stash->{xmlrpc} = 'sophie_session=' . $c->sessionid;
38}
39
40sub fetch_user_data : Private {
41    my ( $self, $c, $user, $dataname ) = @_;
42
43    if (my $rs = $c->model('Base')->resultset('Users')->search(
44        { mail => $user, }
45    )->search_related(
46        'UsersData', { varname => $dataname }
47    )->next) {
48        $c->stash->{xmlrpc} = thaw( decode_base64( $rs->get_column('value') ) );
49    } else {
50        $c->stash->{xmlrpc} = {};
51    }
52
53    return $c->stash->{xmlrpc};
54}
55
56
57sub fetchdata : XMLRPC {
58    my ( $self, $c, $dataname ) = @_;
59
60    $c->user or return {};
61
62    return $c->forward('fetch_user_data', [ $c->user->mail || '', $dataname ]);
63}
64
65sub dumpdata : XMLRPC {
66    my ( $self, $c, $dataname ) = @_;
67
68    return $c->stash->{xmlrpc} = YAML::freeze(
69        $c->forward('fetchdata', [ $dataname ])
70    );
71}
72
73sub set_user_data : Private {
74    my ( $self, $c, $user, $dataname, $data ) = @_;
75
76    my $User = $c->model('Base')->resultset('Users')->find( { mail => $user } )
77        or return;
78
79    $c->model('Base')->resultset('UsersData')->update_or_create({
80        Users => $User,
81        varname => $dataname,
82        value => encode_base64( nfreeze($data) ),
83    });
84    $c->model('Base')->storage->dbh->commit;
85    return $c->stash->{xmlrpc} = 'Updated';
86}
87
88sub setdata : XMLRPC {
89    my ( $self, $c, $dataname, $data ) = @_;
90
91    return $c->forward('set_user_data', [ $c->user->mail, $dataname, $data ]);
92}
93
94sub loaddata : XMLRPC {
95    my ( $self, $c, $dataname, $data ) = @_;
96
97    $c->forward('setdata', [ $dataname, YAML::thaw($data) ]);
98}
99
100sub update_data : XMLRPC {
101    my ( $self, $c, $dataname, $data ) = @_;
102    $c->forward('update_user_data', [ $c->user->mail || '', $dataname, $data ]);
103}
104
105sub update_user_data : Private {
106    my ( $self, $c, $user, $dataname, $data ) = @_;
107
108    my $prev_data = $c->forward('fetch_user_data',
109        [ $user || '', $dataname ]
110    ) || {};
111
112    foreach (keys %$data) {
113        if (defined($data->{$_})) {
114            $prev_data->{$_} = $data->{$_};
115        } else {
116            delete($prev_data->{$_});
117        }
118    }
119
120    $c->forward('set_user_data', [ $user, $dataname, $prev_data ]);
121}
122
123sub set_user_password : Private {
124    my ($self, $c, $user, $clear_password ) = @_;
125
126    my @random = (('a'..'z'), ('A'..'Z'), (0 .. 9));
127    my $salt = join('', map { $random[rand(@random)] } (0..5));
128
129    my $pass = crypt($clear_password, '$1$' . $salt);
130    if (my $rsuser = $c->model('Base::Users')->find({
131            mail => $user,
132        }
133    )) {
134        $rsuser->update({ password => $pass });
135        $c->model('Base')->storage->dbh->commit;
136        return $c->stash->{xmlrpc} = 'Password changed for user ' . $user;
137    } else {
138        $c->error( 'No such user' );
139    }
140}
141
142=head2 user.set_password( PASSWORD )
143
144Change the password for the current user to password C<PASSWORD>.
145
146The change take effect immediately, so user must login again with the new
147password to continue to use the website.
148
149The password is stored internally crypted using UNIX MD5 method.
150
151=cut
152
153sub set_password : XMLRPC {
154    my ( $self, $c, $clear_password ) = @_;
155
156    $c->forward('set_user_password', [ $c->user->mail, $clear_password ]);
157}
158
159=head1 AUTHOR
160
161Olivier Thauvin
162
163=head1 LICENSE
164
165This library is free software. You can redistribute it and/or modify
166it under the same terms as Perl itself.
167
168=cut
169
170__PACKAGE__->meta->make_immutable;
171
1721;
Note: See TracBrowser for help on using the repository browser.