source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases/Sql/objects.pm @ 1154

Last change on this file since 1154 was 1153, checked in by nanardon, 12 years ago

make Sql base set_password() to log a message when work is done
  • Property svn:keywords set to Id Rev
File size: 22.6 KB
Line 
1package LATMOS::Accounts::Bases::Sql::objects;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use base qw(LATMOS::Accounts::Bases::Objects);
8use LATMOS::Accounts::Log;
9use Crypt::RSA;
10use Crypt::RSA::Key::Public::SSH;
11
12our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];
13
14=head1 NAME
15
16LATMOS::Accounts::Bases::Sql::objects - Parent class for SQL object
17
18=cut
19
20sub _attributes_table { $_[0]->_object_table . '_attributes_list' }
21
22sub list {
23    my ($class, $base) = @_;
24
25    my $sth = $base->db->prepare_cached(
26        sprintf(
27            q{select %s as k from %s %s order by %s},
28            $base->db->quote_identifier($class->_key_field),
29            $base->db->quote_identifier($class->_object_table),
30            ($base->{wexported} ? '' : 'where exported = true'),
31            $base->db->quote_identifier($class->_key_field),
32        )
33    );
34    $sth->execute;
35    my @keys;
36    while(my $res = $sth->fetchrow_hashref) {
37        push(@keys, $res->{k});
38    }
39    @keys
40}
41
42sub list_from_rev {
43    my ($class, $base, $rev) = @_;
44    my $sth = $base->db->prepare_cached(
45        sprintf(
46            q{select %s as k from %s where rev > ? %s order by %s},
47            $base->db->quote_identifier($class->_key_field),
48            $base->db->quote_identifier($class->_object_table),
49            ($base->{wexported} ? '' : 'and exported = true'),
50            $base->db->quote_identifier($class->_key_field),
51        )
52    );
53    $sth->execute($rev);
54    my @keys;
55    while(my $res = $sth->fetchrow_hashref) {
56        push(@keys, $res->{k});
57    }
58    @keys
59}
60
61sub _has_extended_attributes { 0 }
62
63sub _get_attr_schema {
64    my ($class, $base, $info) = @_;
65    $info ||= {};
66    if (!$base->{__cache}{$class->_object_table}{inline}) {
67        $base->{__cache}{$class->_object_table}{inline} = [];
68        my $sth = $base->db->prepare(
69            q{SELECT column_name FROM information_schema.columns
70              WHERE table_name = ?}
71        );
72        $sth->execute($class->_object_table);
73        while (my $res = $sth->fetchrow_hashref) {
74            push(@{$base->{__cache}{$class->_object_table}{inline}},
75                $res->{column_name});
76        }
77    }
78    foreach (@{$base->{__cache}{$class->_object_table}{inline}}) {
79        $info->{$_}{inline} = 1;
80        if (m/^(rev|date|create|ikey)$/) {
81            $info->{$_}{ro} = 1
82        }
83    }
84    if ($class->_has_extended_attributes) {
85        if (!$base->{__cache}{$class->_object_table}{extend}) {
86            $base->{__cache}{$class->_object_table}{extend} = [];
87            my $sth = $base->db->prepare_cached(
88                sprintf(
89                    q{select canonical from %s order by canonical},
90                    $base->db->quote_identifier($class->_attributes_table),
91                )
92            );
93            $sth->execute;
94            while (my $res = $sth->fetchrow_hashref) {
95                push(@{$base->{__cache}{$class->_object_table}{extend}},
96                        $res->{canonical});
97            }
98        }
99        foreach (@{$base->{__cache}{$class->_object_table}{extend}}) {
100            $info->{$_} ||= {};
101        }
102    }
103    $info->{exported}   = { inline => 1, formtype => 'CHECKBOX', hide => 1, };
104    $info->{unexported} = { inline => 1, formtype => 'CHECKBOX', };
105
106    $info
107}
108
109# Everything managed by the perl code
110
111sub _managed_fields {
112    my ($class, $for, $base) = @_;
113    return();
114}
115
116sub new {
117    my ($class, $base, $id) = @_;
118    my $sth = $base->db->prepare_cached(
119        sprintf(q{select 1 from %s where %s = ? %s},
120            $base->db->quote_identifier($class->_object_table),
121            $base->db->quote_identifier($class->_key_field),
122            ($base->{wexported} ? '' : 'and exported = true'),
123        ),
124    );
125    my $count = $sth->execute($id);
126    $sth->finish;
127    ($count || 0) == 1 or return;
128    $class->SUPER::new($base, $id);
129}
130
131sub _get_ikey {
132    my ($class, $base, $id) = @_;
133    $base ||= $class->base;
134    $id ||= $class->id;
135    my $sth = $base->db->prepare_cached(
136        sprintf(
137            q{select ikey from %s where %s = ?},
138            $base->db->quote_identifier($class->_object_table),
139            $base->db->quote_identifier($class->_key_field),
140        )
141    );
142    $sth->execute($id);
143    my $res = $sth->fetchrow_hashref;
144    $sth->finish;
145    $res->{ikey}
146}
147
148sub _create {
149    my ($class, $base, $id, %data) = @_;
150
151    # splitting inline from extended
152    my (%first, %second);
153    # Ensure object is exported if not specified
154    $data{exported} = 1 if (!exists($data{exported}));
155    if (exists $data{unexported}) {
156        $data{exported} = $data{unexported} ? 0 : 1;
157        delete $data{unexported}
158    }
159    foreach (keys %data) {
160        my $attr = $base->attribute($class->type, $_) or next;
161        $_ =~ /^exported$/ and $data{$_} = $data{$_} ? 1 : 0;
162        if ($attr->{inline}) {
163            $first{$_} = $data{$_};
164        } else {
165            $second{$_} = $data{$_};
166        }
167    }
168    $first{$class->_key_field} = $id;
169
170    my $sth = $base->db->prepare(
171        sprintf(
172            q{insert into %s (%s) values (%s)},
173            $base->db->quote_identifier($class->_object_table),
174            join(', ', map { $base->db->quote_identifier($_) } sort keys %first),
175            join(',', qw(?) x scalar(keys %first)),
176        )
177    );
178    $sth->execute(map { $first{$_} || undef } sort keys %first) or return;
179
180    $class->new($base, $id)->set_fields(%second);
181
182    1;
183}
184
185sub _delete {
186    my ($class, $base, $id) = @_;
187
188    my $sthd = $base->db->prepare_cached(
189        sprintf(
190            q{delete from %s where %s = ?},
191            $base->db->quote_identifier($class->_object_table),
192            $base->db->quote_identifier($class->_key_field),
193        )
194    );
195    $sthd->execute($id);
196}
197
198sub _rename {
199    my ($class, $base, $id, $newid) = @_;
200
201    my $sthr = $base->db->prepare_cached(
202        sprintf(
203            q{update %s set %s = ? where %s = ?},
204            $base->db->quote_identifier($class->_object_table),
205            $base->db->quote_identifier($class->_key_field),
206            $base->db->quote_identifier($class->_key_field),
207        )
208    );
209
210    if (($sthr->execute($newid, $id) || 0) != 1) {
211        $base->log(LA_ERR, "Erreur renaming %s %s to %s",
212            $class->type,
213            $id, $newid,
214        );
215        return;
216    }
217    1;
218}
219
220=head2 db
221
222Return reference to L<DBI> object.
223
224=cut
225
226sub db {
227    return $_[0]->base->db;
228}
229
230sub _quote_object_table {
231    my ($self) = @_;
232    my $table = $self->_object_table or return;
233    $self->db->quote_identifier($table);
234}
235sub _quote_key_field {
236    my ($self) = @_;
237    my $key_field = $self->_key_field or return;
238    $self->db->quote_identifier($key_field);
239}
240
241sub get_field {
242    my ($self, $field) = @_;
243    if ($field eq 'unexported') {
244        return $self->get_field('exported') ? undef : 1;
245    }
246    my $attr = $self->attribute($field) or return;
247    if ($attr->{inline}) {
248    my $sth = $self->db->prepare_cached(
249        sprintf(
250            q{select %s from %s where %s = ?},
251            $self->db->quote_identifier(lc($field)),
252            $self->_quote_object_table,
253            $self->_quote_key_field,
254        )
255    );
256    $sth->execute($self->id);
257    my $res = $sth->fetchrow_hashref;
258    $sth->finish;
259    return $res->{$field};
260    } elsif ($self->_has_extended_attributes) { # else, then we mandatory have extend attr
261        $self->base->{__cache}{"_" . $self->type} ||= {};
262        my $__cache = $self->base->{__cache}{"_" . $self->type};
263        if (!(exists($__cache->{$self->id})
264            && $__cache->{$self->id}{__time} >= time - 1)) {
265        my $sth = $self->db->prepare_cached(
266            sprintf(
267                q{
268                select attr, value from %s
269                join %s on okey = ikey
270                where %s = ?
271                },
272                $self->db->quote_identifier($self->_object_table. '_attributes'),
273                $self->db->quote_identifier($self->_object_table),
274                $self->db->quote_identifier($self->_key_field),
275            )
276        );
277        $sth->execute($self->id);
278        delete($__cache->{$self->id});
279        $__cache->{$self->id}{__time} = time;
280        while(my $res = $sth->fetchrow_hashref) {
281            push(@{$__cache->{$self->id}{$res->{attr}}}, $res->{value});
282        }
283        #return @values > 1 ? \@values : $values[0];
284        }
285        my $val = $__cache->{$self->id}{$field};
286        return @{$val || []} > 1 ? $val : $val->[0];
287    }
288}
289
290sub set_fields {
291    my ($self, %data) = @_;
292    my $updated_attributes = 0;
293    my @fields;
294    my @vals;
295    my %ext;
296    if (exists($data{unexported})) {
297        $data{exported} = $data{unexported} ? 0 : 1;
298    }
299    if (exists($data{exported})) {
300        $data{exported} ||= 0;
301    }
302    foreach my $field (keys %data) {
303        my $attr = $self->attribute($field);
304        next if ($field eq 'unexported');
305        my $oldval = $self->get_field($field);
306        next if (($data{$field} || '') eq ($oldval || ''));
307        if ($attr->{inline}) {
308        # TODO check fields exists !
309            push(@fields, sprintf("%s = ?", $self->db->quote_identifier($field)));
310            push(@vals, $data{$field});
311        } else {
312            $ext{$field} = $data{$field};
313        }
314    }
315    if (@fields) {
316        my $sth = $self->db->prepare_cached(
317            sprintf(
318                q{update %s set %s where %s = ?},
319                $self->_quote_object_table,
320                join(', ', @fields),
321                $self->_quote_key_field,
322            )
323        );
324        $sth->execute(@vals, $self->id) or do {
325            $self->base->log(LA_ERR,
326                "Cannot update inline field for object %s, %s: %s",
327                $self->type,
328                $self->id,
329                $self->base->db->errstr);
330            return;
331        };
332        $updated_attributes = scalar(@fields);
333    }
334   
335    if ($self->_has_extended_attributes) {
336        my $sthd = $self->db->prepare_cached(
337            sprintf(
338                q{delete from %s where okey = ? and attr = ?},
339                $self->db->quote_identifier($self->_object_table. '_attributes'),
340            ),
341        );
342        my $sthd1 = $self->db->prepare_cached(
343            sprintf(
344                q{delete from %s where okey = ? and attr = ? and value = ?},
345                $self->db->quote_identifier($self->_object_table. '_attributes'),
346            ),
347        );
348        my $sthx = $self->db->prepare_cached(
349            sprintf(
350                q{insert into %s (okey, attr, value) values (?,?,?)},
351                $self->db->quote_identifier($self->_object_table. '_attributes'),
352            )
353        );
354        my $sthu = $self->db->prepare_cached(
355            sprintf(
356                q{update %s set value = ? where okey = ? and attr = ?},
357                $self->db->quote_identifier($self->_object_table. '_attributes'),
358            )
359        );
360
361        my $okey = $self->_get_ikey($self->base, $self->id);
362        foreach my $uattr (keys %ext) {
363            my $attr = $self->attribute($uattr);
364            if ($ext{$uattr}) {
365                if ($attr->{multiple}) {
366                    my $updated = 0;
367                    my $oldvalue = $self->get_field($uattr);
368                    my %newvalues = map { $_ => 1 } (ref $ext{$uattr}
369                        ? @{$ext{$uattr}}
370                        : $ext{$uattr});
371                    foreach (grep { $_ } ref $oldvalue ? @{$oldvalue} : $oldvalue) {
372                        if(exists($newvalues{$_})) {
373                            $newvalues{$_} = 0;
374                        } else {
375                            defined($sthd1->execute($okey, $uattr, $_)) or do {
376                                $self->base->log(LA_ERR,
377                                    "Error while updating attributes on %s/%s %s: %s",
378                                    $self->type,
379                                    $self->id,
380                                    $uattr,
381                                    $self->base->db->errstr
382                                );
383                                return;
384                            };
385                            $updated++;
386                        }
387                    }
388                    foreach (grep { $newvalues{$_} } keys %newvalues) {
389                        $sthx->execute($okey, $uattr, $_) or do {
390                            $self->base->log(LA_ERR,
391                                "Error while updating attributes: %s/%s %s: %s",
392                                $self->type,
393                                $self->id,
394                                $uattr,
395                                $self->base->db->errstr
396                            );
397                            return;
398                        };
399                        $updated++;
400                    }
401                    $updated_attributes++ if ($updated);
402                } else {
403                    my $res = $sthu->execute($ext{$uattr}, $okey, $uattr);
404                    defined($res) or do {
405                        $self->base->log(LA_ERR,
406                            "Error while udapting attributes: %s/%s %s: %s",
407                            $self->type,
408                            $self->id,
409                            $uattr,
410                            $self->base->db->errstr
411                        );
412                        $updated_attributes++;
413                        return;
414                    };
415                    if ($res == 0) {
416                        $res = $sthx->execute($okey, $uattr, $ext{$uattr});
417                        defined($res) or do {
418                            $self->base->log(LA_ERR,
419                                "Error while updating attributes: %s/%s %s: %s",
420                                $self->type,
421                                $self->id,
422                                $uattr,
423                                $self->base->db->errstr
424                            );
425                            $updated_attributes++;
426                            return;
427                        };
428                    }
429                }
430            } else {
431                defined($sthd->execute($okey, $uattr)) or do {
432                    $self->base->log(LA_ERR,
433                        "Error while deleting attributes: %s/%s %s: %s",
434                        $self->otype,
435                        $self->id,
436                        $uattr,
437                        $self->base->db->errstr
438                    );
439                    return;
440                };
441            }
442            $updated_attributes++;
443        }
444    }
445
446    delete($self->base->{__cache}{"_" . $self->type}{$self->id});
447    $updated_attributes;
448}
449
450sub attributes_summary {
451    my ($class, $base, $attribute) = @_;
452    my $attr = $base->attribute($class->type, $attribute);
453    if ($attr->{managed}) { 
454        return $class->SUPER::attributes_summary($base, $attribute);
455    }
456    my $sth = $base->db->prepare_cached(
457        $attr->{inline}
458            ? sprintf(
459                q{select %s as value from %s},
460                $base->db->quote_identifier($attr->iname),
461                $base->db->quote_identifier($class->_object_table),
462            )
463            : sprintf(
464                q{select value from %s where attr = ? group by value},
465                $base->db->quote_identifier($class->_object_table .
466                    '_attributes'),
467            )
468    );
469    $sth->execute($attr->{inline} ? () : ($attribute));
470
471    my @values;
472    while (my $res = $sth->fetchrow_hashref) {
473        push(@values, $res->{value});
474    }
475    @values
476}
477
478sub _set_password {
479    my ($self, $clear_pass) = @_;
480    if (my $attr = $self->base->attribute($self->type, 'userPassword')) {
481        my $field = $attr->iname;
482        my @salt_char = (('a' .. 'z'), ('A' .. 'Z'), (0 .. 9), '/', '.');
483        my $salt = join('', map { $salt_char[rand(scalar(@salt_char))] } (1 .. 8));
484        my $res = $self->set_fields($field, crypt($clear_pass, '$1$' . $salt));
485        if ($res) {
486
487            if (my $serialize = $self->base->get_global_value('rsa_public_key')) {
488                my $public = Crypt::RSA::Key::Public::SSH->new;
489                $public->deserialize(String => [ $serialize ]);
490                my $rsa = new Crypt::RSA ES => 'PKCS1v15';
491                my $rsa_password = $rsa->encrypt (
492                    Message    => $clear_pass,
493                    Key        => $public,
494                    Armour     => 1,
495                ) || die $self->poll->rsa->errstr();
496                if (!$self->_set_c_fields('encryptedPassword', $rsa_password)) {
497                    $self->log(LA_ERR,
498                        "Cannot set 'encryptedPassword' attribute for object %s/%s",
499                        $self->type, $self->id,
500                    );
501                    return;
502                }
503            }
504            $self->base->log(LA_NOTICE,
505                'Mot de passe changé pour %s',
506                $self->id
507            );
508            return 1;
509        }
510    } else {
511        $self->log(LA_WARN,
512            "Cannot set password: userPassword attributes is unsupported");
513    }
514}
515
516sub search {
517    my ($class, $base, @filter) = @_;
518
519    my %attrsql;
520    my %attrbind;
521
522    while (my $item = shift(@filter)) {
523        # attr=foo => no extra white space !
524        # \W is false, it is possible to have two char
525        my ($attr, $mode, $val) = $item =~ /^(\w+)(?:(\W)(.+))?$/ or next;
526        if (!$mode) {
527            $mode = '~';
528            $val = shift(@filter);
529        }
530        my $attribute = $base->attribute($class->type, $attr) or do {
531            $base->log(LA_ERR, "Unknown attribute $attr");
532            next;
533        };
534        defined($val) or $val =  '';
535        $val = $attribute->input($val);
536
537        my $sql;
538
539        # Specific case for unexported attribute, comming from exported value
540        if ($attribute->iname eq 'unexported') {
541            $sql = sprintf(
542                q{select ikey from %s where %s},
543                $base->db->quote_identifier($class->_object_table),
544                $val ? q{exported='f'} : q{exported='t'}
545            )
546        } elsif ($attribute->{inline}) {
547            $sql = sprintf(
548                q{select ikey from %s where %s %s},
549                $base->db->quote_identifier($class->_object_table),
550                $base->db->quote_identifier($attribute->iname),
551                $val eq '*'
552                    ? 'is not NULL'
553                    : $mode eq '~'
554                        ? 'ILIKE ?'
555                        : '= ?' 
556            );
557            push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
558        } else {
559            $sql = sprintf(
560                q{select okey from %s where attr = ? %s},
561                $base->db->quote_identifier(
562                    $class->_object_table . '_attributes'
563                ),
564                $val eq '*'
565                    ? ''
566                    : $mode eq '~'
567                        ? q{and value ILIKE ?}
568                        : q{and value = ?}
569
570            );
571            push(@{$attrbind{$attr}}, $attribute->iname);
572            push(@{$attrbind{$attr}}, $mode eq '~' ? '%' . $val . '%' : $val) unless($val eq '*');
573        }
574
575        push(@{ $attrsql{$attr} }, $sql);
576    }
577    # building the query
578    my @sqlintersec;
579    if (!$base->{wexported}) {
580        push(@sqlintersec, sprintf(
581                q{select ikey from %s where exported = true},
582                $base->db->quote_identifier($class->_object_table)
583            )
584        );
585    }
586    my @bind;
587    foreach (keys %attrsql) {
588        push(@sqlintersec, '(' . join(" union ", @{$attrsql{$_}}) . ")\n");
589        push(@bind, @{$attrbind{$_} || []});
590    }
591    my $sth = $base->db->prepare(
592        sprintf(q{
593            select name from %s
594            %s
595            order by name
596            },
597            $base->db->quote_identifier($class->_object_table),
598            @sqlintersec 
599            ? "where ikey in (\n" . join("\n intersect\n", @sqlintersec) . ")\n"
600            : '',
601        )
602    );
603    $sth->execute(@bind);
604    my @results;
605    while (my $res = $sth->fetchrow_hashref) {
606        push(@results, $res->{name});
607    }
608    return(@results);
609}
610
611=head2 register_attribute
612
613Register attribute into base
614
615=cut
616
617sub register_attribute {
618    my ($class, $base, $attribute, $comment) = @_;
619
620    $class->is_registered_attribute($base, $attribute) and do {
621        $base->log(LA_ERR, "The attribute $attribute already exists");
622        return;
623    };
624    my $sth = $base->db->prepare(
625        sprintf(q{
626            insert into %s (canonical, description)
627            values (?,?)
628            }, $class->_attributes_table)
629    );
630    my $res = $sth->execute($attribute, $comment);
631}
632
633=head2 is_registered_attribute ($base, $attribute)
634
635Return true is attribute is registered into base
636
637=cut
638
639sub is_registered_attribute {
640    my ($class, $base, $attribute) = @_;
641
642    my $sth = $base->db->prepare(
643        sprintf(q{
644            select 1 from %s where canonical = ?
645            }, $class->_attributes_table
646        )
647    );
648    $sth->execute($attribute);
649    my $res = $sth->fetchrow_hashref;
650    return $res ? 1 : 0;
651}
652
653=head2 get_attribute_comment $base, $attribute)
654
655Return comment for C<$attribute>
656
657=cut
658
659# TODO: get_attribute_comment($attr, $base) { $base ||= $self->base ...
660
661sub get_attribute_comment {
662    my ($class, $base, $attribute) = @_;
663    $base->attribute($class->type, $attribute) or do {
664        $base->log(LA_ERR, "The attribute $attribute does not exists");
665        return;
666    };
667    my $sth = $base->db->prepare(
668        sprintf(q{
669            select description from %s
670            where canonical = ?
671            }, $class->_attributes_table)
672    );
673    $sth->execute($attribute);
674    if (my $res = $sth->fetchrow_hashref) {
675        $sth->finish;
676        return $res->{description};
677    } else {
678        return;
679    }
680}
681
682=head2 set_attribute_comment ($base, $attribute, $comment)
683
684Set comment to attribute
685
686=cut
687
688sub set_attribute_comment {
689    my ($class, $base, $attribute, $comment) = @_;
690
691    my $attr = $base->attribute($class->type, $attribute) or do {
692        $base->log(LA_ERR, "The attribute $attribute does not exists");
693        return;
694    };
695    $attr->{inline} and do {
696        $base->log(LA_ERR,
697            "Cannot set comment to inline attribute, sorry, blame the author !"
698        );
699        return;
700    };
701    my $sth = $base->db->prepare(
702        sprintf(q{
703            update %s set description = ?
704            where canonical = ?
705            }, $class->_attributes_table)
706    );
707    my $res = $sth->execute($comment, $attribute);
708}
709
710
711
7121;
713
714__END__
715
716=head1 SEE ALSO
717
718L<LATMOS::Accounts::Bases::Sql>
719
720L<LATMOS::Accounts::Bases::Objects>
721
722=head1 AUTHOR
723
724Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
725
726=head1 COPYRIGHT AND LICENSE
727
728Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
729
730This library is free software; you can redistribute it and/or modify
731it under the same terms as Perl itself, either Perl version 5.10.0 or,
732at your option, any later version of Perl 5 you may have available.
733
734
735=cut
Note: See TracBrowser for help on using the repository browser.