source: trunk/LATMOS-Accounts/lib/LATMOS/Accounts/Bases.pm

Last change on this file was 2624, checked in by nanardon, 2 months ago

Revert alternative id attribute for synchro
  • Property svn:keywords set to Id Rev
File size: 33.7 KB
Line 
1package LATMOS::Accounts::Bases;
2
3use 5.010000;
4use strict;
5use warnings;
6use LATMOS::Accounts::Bases::Objects;
7use LATMOS::Accounts::Bases::Attributes;
8use LATMOS::Accounts::Log;
9use LATMOS::Accounts::Utils qw( exec_command to_ascii );
10use DateTime;
11
12our $VERSION = (q$Rev: 2156 $ =~ /^Rev: (\d+) /)[0];
13
14=head1 NAME
15
16LATMOS::Accounts::Bases - Base class for account data bases
17
18=head1 SYNOPSIS
19
20  use LATMOS::Accounts::Bases;
21  my $base = LATMOS::Accounts::Bases->new('type', %options);
22  ...
23
24=head1 DESCRIPTION
25
26This module provide basic functions for various account base
27
28=head1 FUNCTIONS
29
30=cut
31
32=head2 new($type, %options)
33
34Return, if success, a new data base account object, $type is
35account base type, %options to setup the base.
36
37=cut
38
39sub new {
40    my ($class, $type, $options) = @_;
41
42    my $pclass = ucfirst(lc($type));
43    eval "require LATMOS::Accounts::Bases::$pclass;";
44    if ($@) {
45        la_log(LA_DEBUG, "Failed to load base type `%s': %s", $type, $@);
46        return
47    }
48    my $base = "LATMOS::Accounts::Bases::$pclass"->new(%{$options->{params}})
49        or return;
50
51    $options->{params}{monitored} ||= {};
52
53    $base->{_type} = lc($pclass);
54    $base->{_label} = $options->{label};
55    $base->{_options} = $options->{params};
56    $base->{wexported} = 0;
57    $base->{defattr} = $options->{defattr};
58    $base->{_acls} = $options->{acls};
59    $base->{_allowed_values} = $options->{allowed_values};
60    $base->{_la} = $options->{la};
61
62    $base->{defattr}{'user.min_uid'}  ||= 1000;
63    $base->{defattr}{'group.min_gid'} ||= 1000;
64
65    # Callback, the list bellow give the supported callback
66    $base->{_cb} = $options->{cb} || {
67        commit => undef,
68        postcommit => undef,
69    };
70
71    my $username = $options->{username} || $ENV{LA_USERNAME};
72
73    $base->SetConnectedUser($username) if ($username);
74
75    la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($base->label || 'N/A'), $pclass);
76    $base
77}
78
79=head2 SetCallBack( $cb, $code )
80
81Set callbalc $<cb> to function C<$code>.
82
83=cut
84
85sub SetCallBack {
86    my ( $self, $cb, $code ) = @_;
87
88    if (exists ($self->{_cb}{$cb})) {
89        return $self->{_cb}{$cb} = $code;
90    }
91}
92
93=head2 GetCallBack( $cb )
94
95Set callback $<cb> to function C<$code>.
96
97=cut
98
99sub GetCallBack {
100    my ( $self, $cb ) = @_;
101
102    if (exists ($self->{_cb}{$cb})) {
103        $self->{_cb}{$cb} || sub { 1; };
104    }
105}
106
107=head2 load
108
109Make account base loading data into memory if need.
110Should always be called, if database fetch data on the fly
111(SQL, LDAP), the function just return True.
112
113=cut
114
115# override by the database driver if need
116sub load { 1 }
117
118=head2 label
119
120Return the database label
121
122=cut
123
124sub label {
125    $_[0]->{_label} || 'NoLabel';
126}
127
128=head2 type
129
130Return the type of the base
131
132=cut
133
134sub type {
135    $_[0]->{_type};
136}
137
138=head2 la
139
140return LATMOS::Accounts object parent to the base
141
142=cut
143
144sub la { $_[0]->{_la} };
145
146=head2 config ($opt)
147
148Return options from config
149
150=cut
151
152sub config {
153    my ($self, $opt, $default) = @_;
154    return defined($self->{_options}{$opt}) ? $self->{_options}{$opt} : $default;
155}
156
157=head2 wexported
158
159See L</unexported>
160
161=cut
162
163sub wexported { unexported(@_) }
164
165=head2 unexported ($wexported)
166
167Set base to report unexported object or not
168
169=cut
170
171sub unexported {
172    my ($self, $wexported) = @_;
173    my $old = $self->{wexported};
174    if (defined($wexported)) {
175        $self->{wexported} = $wexported;
176        $self->log(LA_DEBUG, "Switching exported mode: %s => %s", $old,
177            $wexported);
178    }
179    return($old || 0);
180}
181
182=head2 temp_switch_unexported($CODE, $value)
183
184Switch the base to unexported mode given by C<$value>, run C<$CODE>, restore
185back the previous state and return the result of code ref.
186
187=cut
188
189sub temp_switch_unexported (&;$) {
190    my ($self, $sub, $value) = @_;
191
192    my $old = $self->unexported($value || 0);
193    my $res = $sub->();
194    $self->unexported($old);
195    return $res;
196}
197
198=head2 log($level, $msg, $arg)
199
200Log a message prefixed by database information
201
202=cut
203
204sub log {
205    my ($self, $level, $msg, @args) = @_;
206    my $prefix = 'Base(' . $self->type . '/' . $self->label . ')';
207    LATMOS::Accounts::Log::la_log($level, "$prefix $msg", @args);
208}
209
210=head2 ReportChange($otype, $name, $ref, $changetype, $message, @args)
211
212Functions to report back
213
214=cut 
215
216sub ReportChange {}
217
218=head2 list_supported_objects(@otype)
219
220Return a list of supported object
221
222@type is an additionnal list of objects to check
223
224=cut
225
226sub list_supported_objects {
227    my ($self, @otype) = @_;
228    my %res;
229    foreach my $inc (@INC) {
230        my $sub = 'LATMOS::Accounts::Bases::' . ucfirst($self->type);
231        $sub =~ s/::/\//g;
232        foreach (glob("$inc/$sub/[A-Z]*.pm")) {
233            s/.*\///;
234            s/\.pm$//;
235            $res{lc($_)} = 1;
236        }
237    }
238    $res{$_} = 1 foreach(@otype);
239    my @sobj = grep { $self->is_supported_object($_) } keys %res;
240    la_log(LA_DEBUG, "Base %s supported objects: %s", $self->type, join(', ', @sobj));
241    return @sobj;
242}
243
244=head2 ListSubObjectOType($otype)
245
246Return a list of sub object type supported by C<otype> objects.
247
248=cut
249
250sub ListSubObjectOType {
251    my ($self, $otype) = @_;
252
253    # finding perl class:
254    my $pclass = $self->_load_obj_class($otype) or return;
255    my $definition = "$pclass"->GetOtypeDef($self) or return;
256
257    return keys %{ $definition || {} }
258}
259
260=head2 GetSubObjectKey($otype, $sotype)
261
262Return the key linking sub object C<$sotype> to object type C<$otype>
263
264=cut
265
266sub GetSubObjectKey {
267    my ($self, $otype, $sotype) = @_;
268
269    # finding perl class:
270    my $pclass = $self->_load_obj_class($otype) or return;
271    my $definition = "$pclass"->GetOtypeDef($self, $sotype) or return;
272
273    return $definition->{$sotype};
274}
275
276
277=head2 ordered_objects
278
279Return supported object type ordered in best order for synchronisation
280
281=cut
282
283sub ordered_objects {
284    my ($self) = @_;
285
286    my %deps;
287    my %maxdeps;
288    my @objs = sort { $b cmp $a } $self->list_supported_objects;
289    foreach my $obj (@objs) {
290        foreach my $at ($self->list_canonical_fields($obj)) {
291            my $attr = $self->attribute($obj, $at);
292            $attr->ro and next;
293            $attr->delayed and next;
294            if (my $res = $attr->reference) {
295                $deps{$obj}{$res} ||= 1;
296                if ($attr->mandatory) {
297                    $deps{$obj}{$res} = 2;
298                    $maxdeps{$res} = 1;
299                }
300            }
301        }
302    }
303
304    sort {
305        if (keys %{$deps{$a} || {}}) {
306            if (keys %{$deps{$b} || {}}) {
307                return (
308                    ($deps{$a}{$b} || 0) > ($deps{$b}{$a} || 0) ?  1 :
309                    ($deps{$b}{$a} || 0) > ($deps{$a}{$b} || 0) ? -1 :
310                    ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0)
311                );
312            } else {
313                return 1;
314            }
315        } elsif (keys %{$deps{$b} || {}}) {
316            return -1;
317        } else {
318            return  ($maxdeps{$b} || 0) - ($maxdeps{$a} || 0)
319        }
320    } @objs;
321}
322
323sub _load_obj_class {
324    my ($self, $otype) = @_;
325
326    $otype or die "No type given: " . join(', ', caller) . "\n";
327    # finding perl class:
328    my $pclass = ref $self;
329    $pclass .= '::' . ucfirst(lc($otype));
330    eval "require $pclass;";
331    if ($@) {
332        $self->log(LA_DEBUG, 'Cannot load perl class %s', $pclass);
333        return
334    } # error message ?
335    return $pclass;
336}
337
338
339=head2 is_supported_object($otype)
340
341Return true is object type $otype is supported
342
343=cut
344
345sub is_supported_object {
346    my ($self, $otype) = @_;
347   
348    if (my $pclass = $self->_load_obj_class($otype)) {
349        if ($pclass->can('is_supported')) {
350            return $pclass->is_supported($self);
351        } else {
352            return 1;
353        }
354    } else {
355        return 0;
356    }
357}
358
359=head2 list_objects($otype, %options)
360
361Return the list of UID for object of $otype.
362
363=cut
364
365sub list_objects {
366    my ($self, $otype) = @_;
367    my $pclass = $self->_load_obj_class($otype) or return;
368    $pclass->list($self);
369}
370
371=head2 listRealObjects
372
373Return the list of UID for object of $otype, alias objects are not return
374
375Options depend of database support
376
377=cut
378
379sub listRealObjects {
380    my ($self, $otype) = @_;
381    $self->list_objects($otype);
382}
383
384=head2 get_object($type, $id)
385
386Return an object of $type (typically user or group) having identifier
387$id.
388
389=cut
390
391sub get_object {
392    my ($self, $otype, $id) = @_;
393
394    # finding perl class:
395    my $pclass = $self->_load_obj_class($otype) or return;
396    my $newobj = "$pclass"->new($self, $id);
397
398    defined($newobj) or do {
399        $self->log(LA_DEBUG, "$pclass->new() returned undef for $otype / %s", $id || '(none)');
400        return;
401    };
402
403    $newobj->{_base} = $self;
404    $newobj->{_type} = lc($otype);
405    $newobj->{_id} ||= $id;
406
407    return $newobj;
408}
409
410=head2 create_c_object($type, $id, %data)
411
412Create and return an object of type $type with unique id
413$id having %data using canonical fields
414
415=cut
416
417sub create_c_object {
418    my ($self, $otype, $id, %cdata) = @_;
419    $self->check_acl($otype, '@CREATE', 'w') or do {
420        $self->log(LA_WARN, 'permission denied to create object type %s',
421            $otype);
422        return;
423    };
424
425    $self->_create_c_object($otype, $id, %cdata);
426}
427
428sub _create_c_object {
429    my ($self, $otype, $id, %cdata) = @_;
430
431    $id ||= ''; # Avoid undef
432
433    if (my $chk = (
434        lc($otype) eq 'user' || lc($otype) eq 'group') ? LATMOS::Accounts::Utils::check_ug_validity($id)
435        : lc($otype) eq 'nethost' ? LATMOS::Accounts::Utils::check_host_validity($id)
436        : LATMOS::Accounts::Utils::check_oid_validity($id)) {
437        $self->log(LA_ERR, "Cannot create $otype with ID $id `%s:'", $chk);
438        return;
439    }
440
441    my %data;
442
443    # populating default value
444    {
445        my %default = $self->compute_default($otype, $id, %cdata);
446        foreach my $k (keys %default) {
447            my $attr = $self->attribute($otype, $k) or next;
448            $attr->ro and next;
449            $data{$k} = $default{$k};
450        }
451    }
452
453    if ( $self->is_supported_object('templates') ) {
454        if ( $cdata{template} ) {
455            my $template = $self->get_object('templates', $cdata{template} ) or do {
456                $self->log(LA_ERR, "Cannot load template $cdata{template}");
457                return;
458            };
459
460            my $TOType = $template->_get_attributes('objecttype');
461            if ( $TOType ne $otype ) {
462                $self->log(LA_ERR, "Template $cdata{template} is for object type $TOType, not $otype");
463                return;
464            }
465
466            my $text = join("\n", $template->_get_attributes('data'));
467            my %tdata = LATMOS::Accounts::Utils::parse_obj_text($text || '');
468
469            foreach my $k ( keys %tdata ) {
470                $data{$k} = $tdata{$k};
471            }
472
473            delete( $cdata{template} );
474        }
475    }
476
477    my $sub;
478    foreach my $cfield (keys %cdata) {
479        # Parsing subobject creation:
480
481        if (my ($sotype, $key, $scfield) = $cfield =~ /^(\w+)(?:\[(\w+)\])?\.(.*)/) {
482            $key ||= '_';
483            $sub->{$sotype}{$key}{$scfield} = $cdata{$cfield};
484        } else {
485            my $attribute = $self->attribute($otype, $cfield) or next;
486            $attribute->ro and next;
487            $data{$cfield} = $cdata{$cfield};
488        }
489    }
490
491    foreach my $cfield (keys %data) {
492        $self->check_allowed_values($otype, $cfield, $data{$cfield}) or do {
493            my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
494            $self->log(LA_ERR, "Cannot create $otype, wrong value%s", ($last ? ": $last" : ''));
495            return;
496        };
497    }
498
499    $self->create_object($otype, $id, %data) or return;
500    my $obj = $self->get_object($otype, $id) or return;
501    $obj->ReportChange('Create', 'Object created with %s', join(', ', sort keys %cdata));
502
503    foreach my $attrname (keys %data) {
504        my $attribute = $self->attribute($obj->type, $attrname) or next;
505        $attribute->monitored or next;
506
507        $obj->ReportChange('Attributes', '%s set to %s', $attrname,
508            (ref $data{$attrname}
509                ? join(', ', @{ $data{$attrname} })
510                : $data{$attrname}) || '(none)');
511    }
512
513    if ($sub) {
514
515        # Security: if caller is create_c_object calling it to check permission ?
516        # See below
517        # my ($caller) = caller();
518        # my $subcreate = $caller eq 'create_c_object' ? 'create_c_object' : __SUB__;
519       
520        # Trying to create subobject
521        foreach my $sotype (keys %$sub) {
522            my $SubKeyRef = $self->GetSubObjectKey($otype, $sotype) or do {
523                $self->log(LA_ERR, "Cannot create object type $sotype, subtype of $otype not defined");
524                return;
525            };
526            foreach my $skey (keys %{ $sub->{$sotype} || {} }) {
527                # Building id
528                my $info = $sub->{$sotype}{$skey} || {};
529                # For id: if key is given using it, otherwise using random
530                my $sid = 
531                    $info->{$SubKeyRef} ||
532                    $id . '-' . join('', map { ('a' .. 'z')[rand(26)] } (0 .. 6));
533                $info->{$SubKeyRef} = $id;
534
535                # Here we don't check permission to create sub object:
536                $self->_create_c_object($sotype, $sid, %{ $info || {} }) or return;
537            }
538        }
539    }
540
541    $obj
542}
543
544=head2 create_object($type, $id, %data)
545
546Create and return an object of type $type with unique id
547$id having %data.
548
549This method should be provided by the data base handler.
550
551=cut
552
553sub create_object {
554    my ($self, $otype, $id, %data) = @_;
555
556    "$id" or do {
557        $self->log(LA_ERR, "Cannot create %s object with empty id",
558            $otype);
559        return;
560    };
561    my $pclass = $self->_load_obj_class($otype) or do {
562        $self->log(LA_ERR, "Cannot create %s object type (cannot load class)",
563            $otype);
564        return;
565    };
566
567    if (!$pclass->checkValues($self, $id, %data)) {
568        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
569        la_log(LA_ERR,
570            'Cannot create %s (%s) in base %s (%s): wrong value%s',
571            $id, $otype, $self->label, $self->type,
572            ($last ? ": $last" : ''),
573        );
574        return;
575    }
576
577    if ($pclass->_create($self, $id, %data)) {
578        la_log(LA_INFO,
579            'Object %s (%s) created in base %s (%s)',
580            $id, $otype, $self->label, $self->type,
581        );
582    } else {
583        my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR);
584        la_log(LA_ERR,
585            'Object creation %s (%s) in base %s (%s) failed%s',
586            $id, $otype, $self->label, $self->type,
587            ($last ? ": $last" : ''),
588        );
589        return;
590    };
591
592    $self->get_object($otype, $id);
593}
594
595=head2 defaultAttributeValue($otype, $attr)
596
597Return default static value for attribute C<$attr>
598
599=cut
600
601sub defaultAttributeValue {
602    my ($self, $otype, $attr) = @_;
603
604    my %def = %{ $self->{defattr} || {}};
605    return $def{"$otype.$attr"} || '';
606}
607
608=head2 compute_default($otype, $id, %cdata)
609
610Return a hash containing value to set for new object
611
612=cut
613
614sub compute_default {
615    my ($self, $otype, $id, %cdata) = @_;
616
617    my %default;
618    foreach my $def (keys %{ $self->{defattr} || {}}) {
619        if ($def =~ /^$otype\.(.*)$/) {
620            $default{$1} = $self->{defattr}{$def} if(!$cdata{$1});
621        }
622    }
623
624    # computed default value (not a simple set)
625    if (lc($otype) eq 'user') {
626        if (!$cdata{homeDirectory}) {
627            $default{homeDirectory} = $self->{defattr}{'user.homebase'}
628                ? $self->{defattr}{'user.homebase'} . "/$id" 
629                : '';
630        }
631
632        if (!$cdata{uidNumber}) {
633            $default{uidNumber} ||= $self->find_next_numeric_id('user', 'uidNumber',
634            $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'});
635        }
636
637        my $mailid = $cdata{givenName} && $cdata{sn}
638            ? sprintf('%s.%s',
639                to_ascii(lc($cdata{givenName})),
640                to_ascii(lc($cdata{sn})),)
641            : undef;
642        if ($mailid) {
643            $mailid =~ s/\s+/-/g;
644            $mailid =~ s/['"]//g;
645        }
646
647        if ($mailid &&
648            $self->is_supported_object('aliases') &&
649            ! $self->get_object('aliases', $mailid)) {
650            if (my $attr = $self->attribute($otype, 'mail')) {
651                if ((!$attr->ro) && $self->{defattr}{'user.maildomain'}) {
652                    $default{mail} ||= sprintf('%s@%s',
653                    $mailid,
654                    $self->{defattr}{'user.maildomain'});
655                }
656            }
657            if (my $attr = $self->attribute($otype, 'aliases')) {
658                $default{aliases} ||= $mailid unless ($attr->ro);
659            }
660            if (my $attr = $self->attribute($otype, 'revaliases')) {
661                $default{revaliases} ||= $mailid unless ($attr->ro);
662            }
663        }
664    } elsif (lc($otype) eq 'group') {
665        if (!$cdata{gidNumber}) {
666            $default{gidNumber} ||= $self->find_next_numeric_id(
667                'group', 'gidNumber',
668                $self->{defattr}{'group.min_gid'},
669                $self->{defattr}{'group.max_gid'}
670            );
671        }
672    }
673
674    return %default;
675}
676
677sub _allowed_values {
678    $_[0]->{_allowed_values}
679}
680
681=head2 obj_attr_allowed_values ($otype, $attr)
682
683Return value allowed for this attribute
684
685=cut
686
687sub obj_attr_allowed_values {
688    my ($self, $otype, $attr) = @_;
689    return grep { defined($_) } $self->obj_attr_param($otype, $attr, 'allowed');
690}
691
692=head2 check_allowed_values ($otype, $attr, $attrvalues)
693
694Check attributes C<$attr> of object type C<$otype> allow values C<$attrvalues>
695
696=cut
697
698sub check_allowed_values {
699    my ($self, $otype, $attr, $attrvalues) = @_;
700    $self->_allowed_values or return 1;
701    my @values = ref $attrvalues ? @{ $attrvalues } : $attrvalues;
702    foreach my $value (@values) {
703        $value or next;
704        if (my @allowed = $self->obj_attr_allowed_values($otype, $attr)) {
705            grep { $value eq $_ } @allowed or do {
706                $self->log(LA_ERR,
707                    "value `%s' is not allow for %s.%s per configuration (allowed_values)",
708                    $value, $otype, $attr
709                );
710                return;
711            };
712        }
713    }
714    return 1;
715}
716
717=head2 obj_attr_param ( $otype, $attr, $param )
718
719Return, if any, the paramater $param for this attribute from allowed_values config file
720
721=cut
722
723sub obj_attr_param {
724    my ( $self, $otype, $attr, $param ) = @_;
725
726    if ( $self->_allowed_values &&
727        $self->_allowed_values->SectionExists("$otype.$attr")) {
728        return $self->_allowed_values->val( "$otype.$attr", $param );
729    }
730    return;
731}
732
733=head2 list_canonical_fields($otype, $for)
734
735Return the list of supported fields by the database for object type $otype.
736
737Optionnal $for specify the goal for which the list is requested, only supported
738fields will be returns
739
740=cut
741
742sub list_canonical_fields {
743    my ($self, $otype, $for) = @_;
744    $for ||= 'rw';
745    my $pclass = $self->_load_obj_class($otype) or return;
746    sort $pclass->_canonical_fields($self, $for);
747}
748
749sub _get_attr_schema {
750    my ($self, $otype) = @_;
751    my $pclass = $self->_load_obj_class($otype) or return;
752    return $pclass->_get_attr_schema($self);
753}
754
755=head2 get_attr_schema
756
757Deprecated
758
759=cut
760
761# TODO: kill this
762
763sub get_attr_schema {
764    my ($self, $otype, $attribute) = @_;
765    my $info = $self->_get_attr_schema($otype);
766    if ($info->{$attribute}) {
767        return $info->{$attribute};
768    } else {
769        return;
770    }
771}
772
773=head2 attribute($otype, $attribute)
774
775Return attribute object.
776
777See L<LATMOS::Accounts::Bases::Attribute>
778
779=cut
780
781sub attribute {
782    my ($self, $otype, $attribute) = @_;
783
784    my $attrinfo;
785    if (!ref $attribute) {
786       $attrinfo = $self->get_attr_schema($otype, $attribute)
787            or return;
788        $attrinfo->{name} = $attribute;
789    } else {
790        $attrinfo = $attribute;
791    }
792
793    return LATMOS::Accounts::Bases::Attributes->new(
794        $attrinfo,
795        $self,
796        $otype,
797    );
798}
799
800=head2 delayed_fields
801
802DEPRECATED
803
804=cut 
805
806# TODO: kill this
807
808sub delayed_fields {
809    my ($self, $otype, $for) = @_;
810    $self->log(LA_WARN, "calling DEPRECATED delayed_fields " . join(',',
811            caller));
812    $for ||= 'rw';
813    my @attrs;
814    foreach ($self->list_canonical_fields($otype, $for)) {
815        my $attr = $self->attribute($otype, $_) or next;
816        $for =~ /w/ && $attr->ro and next;
817        $attr->delayed or next;
818        push(@attrs, $_);
819    }
820    @attrs
821}
822
823=head2 ochelper ($otype)
824
825Return L<LATMOS::Accounts::Bases::OChelper> object
826
827=cut
828
829sub ochelper {
830    my ($self, $otype) = @_;
831    my $pclass = ucfirst(lc($otype));
832    foreach my $class (
833        ref($self) . '::OCHelper::' . $pclass,
834        ref($self) . '::OCHelper',
835        "LATMOS::Accounts::Bases::OCHelper::$pclass",
836        'LATMOS::Accounts::Bases::OCHelper' ) {
837        eval "require $class;";
838        if ($@) { next } # error message ?
839        my $ochelper = "$class"->new($self, $otype);
840        return $ochelper;
841    }
842    return;
843}
844
845=head2 delete_object($otype, $id)
846
847Destroy from data base object type $otype having id $id.
848
849=cut
850
851sub delete_object {
852    my ($self, $otype, $id) = @_;
853    my $obj = $self->get_object($otype, $id) or do {
854        $self->log(LA_WARN, 'Cannot delete %s/%s: no such object',
855            $otype, $id);
856        return;
857    };
858    $self->check_acl($obj, '@DELETE', 'w') or do {
859        $self->log(LA_WARN, 'permission denied to delete %s/%s',
860            $otype, $id);
861        return;
862    };
863    my $ref = $obj->Iid;
864    if (my $res = $self->_delete_object($otype, $id)) {
865        $self->ReportChange($otype, $id, $ref, 'Delete', 'Object deleted');
866        return $res;
867    }
868    return;
869}
870
871sub _delete_object {
872    my ($self, $otype, $id) = @_;
873    my $pclass = $self->_load_obj_class($otype);
874    $pclass->_delete($self, $id);
875}
876
877=head2 rename_object($otype, $id, $newid)
878
879Rename an object.
880
881=cut
882
883sub rename_object {
884    my ($self, $otype, $id, $newid) = @_;
885
886    $self->log(LA_DEBUG, "Trying to rename $otype/$id to $newid");
887    my $obj = $self->get_object($otype, $id) or do {
888        $self->log(LA_WARN, 'Cannot rename %s/%s: no such object',
889            $otype, $id);
890        return;
891    };
892    if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group')
893        ? LATMOS::Accounts::Utils::check_ug_validity($newid)
894        : LATMOS::Accounts::Utils::check_oid_validity($newid)) {
895        $self->log(LA_ERR, "Cannot rename $otype/$id to ID $newid `%s:'", $chk);
896        return;
897    }
898    $self->check_acl($obj, '@DELETE', 'w') &&
899    $self->check_acl($obj, '@CREATE', 'w') or do {
900        $self->log(LA_WARN, 'permission denied to rename %s/%s',
901            $otype, $id);
902        return;
903    };
904
905    my $oldref = $obj->Iid;
906
907    if (my $res = $self->_rename_object($otype, $id, $newid)) {
908        my $newobj = $self->get_object($otype, $newid) or do {
909            $self->log(LA_WARN, 'Cannot get object %s/%s: rename failed ?',
910                $otype, $id);
911            return;
912        };
913
914        $self->ReportChange($otype, $id, $oldref, 'Rename', 'Object rename to %s', $newid);
915        $newobj->ReportChange('Rename', 'Object renamed from %s', $id);
916        return $res;
917    }
918    return;
919}
920
921sub _rename_object {
922    my ($self, $otype, $id, $newid) = @_;
923    my $pclass = $self->_load_obj_class($otype);
924    $pclass->can('_rename') or do {
925        $self->log(LA_ERR, 'rename object type %s is unsupported', $otype);
926        return;
927    };
928    $pclass->_rename($self, $id, $newid);
929}
930
931=head2 is_transactionnal
932
933Return True is the database support commit and rollback
934
935=cut
936
937sub is_transactionnal {
938    my ($self) = @_;
939    return($self->can('_rollback') && $self->can('_commit'));
940}
941
942=head2 commit
943
944Save change into the database if change are not done immediately.
945This should always be called as you don't know when change are applied.
946
947Return always true if database does not support any transaction.
948
949The driver should provides a _commit functions to save data.
950
951=cut
952
953sub commit {
954    my ($self) = @_;
955    if ($self->can('_commit')) {
956        la_log(LA_DEBUG, 'Commiting data');
957        if (!(my $res = $self->_commit)) {
958            la_log(LA_ERR, "Commit error on %s", $_->label);
959            return $res;
960        }
961    }
962
963    $self->GetCallBack('commit')->();
964
965    $self->postcommit();
966
967    return 1;
968}
969
970=head2 postcommit
971
972Run postcommit command
973
974=cut
975
976sub postcommit {
977    my ($self) = @_;
978
979    if ($self->{_options}{postcommit}) {
980        exec_command($self->{_options}{postcommit},
981            {
982                BASE => $self->label,
983                BASETYPE => $self->type,
984                HOOK_TYPE => 'POST',
985                CONFIG => $self->{_options}{configdir}, 
986            }
987        );
988        $self->GetCallBack('postcommit')->();
989    } else {
990        return 1;
991    }
992}
993
994=head2 rollback
995
996If database support transaction, rollback changes. Return false
997if database does not support.
998
999If supported, driver should provides a _rollback functions
1000
1001=cut
1002
1003sub rollback {
1004    my ($self) = @_;
1005    if ($self->can('_rollback')) {
1006       la_log(LA_DEBUG, 'Rolling back data');
1007       return $self->_rollback;
1008   } else {
1009       return 0;
1010   }
1011}
1012
1013=head2 current_rev
1014
1015Return the current revision of the database
1016
1017Must be provide by base driver if incremental synchro is supported
1018
1019=cut
1020
1021sub current_rev { return }
1022
1023=head2 list_objects_from_rev($otype, $rev)
1024
1025Return the list of UID for object of $otype.
1026
1027=cut
1028
1029sub list_objects_from_rev {
1030    my ($self, $otype, $rev) = @_;
1031    my $pclass = $self->_load_obj_class($otype) or return;
1032    if (defined($rev) && $pclass->can('list_from_rev')) {
1033        return $pclass->list_from_rev($self, $rev);
1034    } else {
1035        # no support, return all objects...
1036        return $self->list_objects($otype);
1037    }
1038}
1039
1040=head2 sync_object_from($srcbase, $otype, $id, %options)
1041
1042Sync object type C<$otype> C<$id> from base C<$srcbase> to current base.
1043
1044C<%options>:
1045
1046=over 4
1047
1048=item nodelete
1049
1050Don't delete object if the object synchronize don't exist in source base
1051
1052=back
1053
1054=cut
1055
1056sub sync_object_from {
1057    my ($self, $srcbase, $otype, $id, %options) = @_;
1058
1059    # is the object type supported by both
1060    foreach ($self, $srcbase) {
1061        $_->is_supported_object($otype) or return '';
1062    }
1063   
1064    if (my $srcobj = $srcbase->get_object($otype, $id)) {
1065        return $self->sync_object($srcobj, %options);
1066    } elsif (!$options{nodelete}) {
1067        $self->_delete_object($otype, $id) and return 'DELETED';
1068    }
1069    return;
1070}
1071
1072=head2 sync_object
1073
1074Synchronise an object into this base
1075
1076=cut
1077
1078sub sync_object {
1079    my ($self, $srcobj, %options) = @_;
1080    $self->is_supported_object($srcobj->type) or return '';
1081    my @fields = $options{attrs}
1082        ? @{ $options{attrs} }
1083        : $self->list_canonical_fields($srcobj->type, 'w');
1084    my %data;
1085    foreach my $attrname (@fields) {
1086        # check attribute exists in source:
1087        my $attr = $srcobj->attribute($attrname) or next;
1088        my $destattr = $self->attribute( $srcobj->type, $attrname ) or next;
1089        $attr->readable or next;
1090        $destattr->ro and next;
1091        if (! $options{onepass}) {
1092            if ($options{firstpass}) {
1093                $destattr->delayed and next;
1094            } else {
1095                $destattr->delayed or next;
1096            }
1097        }
1098        my $srcattrname = $attr->{auto} ? "_$attrname" : $attrname;
1099        $data{$attrname} = $srcobj->GetAttributeValue($srcattrname);
1100    }
1101
1102    if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id )) {
1103        keys %data or return 'SYNCED';
1104        foreach (keys %data) {
1105            if (!$dstobj->attribute($_) ||
1106                $dstobj->attribute($_)->ro) {
1107                delete($data{$_});
1108            }
1109        }
1110        my $res = $dstobj->_set_c_fields(%data);
1111        if (defined $res) {
1112            return $res ? 'SYNCED' : '';
1113        } else {
1114            return;
1115        }
1116    } elsif(!$options{nocreate}) {
1117        if ((! $options{firstpass}) && (!$options{onepass})) {
1118            $self->log(LA_ERR, 'This is not first pass, creation wanted but denied');
1119            return;
1120        }
1121        if (my $res = $self->_create_c_object($srcobj->type, $srcobj->id, %data)) {
1122            return 'CREATED'
1123        } else {
1124            return;
1125        }
1126    } else {
1127        # No error, but creation is denied
1128        return 'Creation skipped';
1129    }
1130
1131    return;
1132}
1133
1134=head2 search_objects($otype, @filter)
1135
1136Search object according @filter. @filter is a list
1137of field/value which should match.
1138
1139A default function is provided but each db driver can provide
1140an optimize version.
1141
1142=cut
1143
1144sub search_objects {
1145    my ($self, $otype, @filter) = @_;
1146    my $pclass = $self->_load_obj_class($otype) or return;
1147    $pclass->search($self, @filter);
1148}
1149
1150=head2 attributes_summary($otype, $attr)
1151
1152Return couple object id / value for attribute C<$attr> of object type C<$otype>
1153
1154This method is designed to be faster than fetching object one by one.
1155
1156=cut
1157
1158sub attributes_summary {
1159    my ($self, $otype, $attr) = @_;
1160    my $pclass = $self->_load_obj_class($otype) or return;
1161    $pclass->attributes_summary($self, $attr);
1162}
1163
1164=head2 attributes_summary_by_object($otype, $attr)
1165
1166Return couple object id / value for attribute C<$attr> of object type C<$otype>
1167
1168This method is designed to be faster than fetching object one by one.
1169
1170=cut
1171
1172sub attributes_summary_by_object {
1173    my ($self, $otype, $attr) = @_;
1174    my $pclass = $self->_load_obj_class($otype) or return;
1175    $pclass->attributes_summary_by_object($self, $attr);
1176}
1177
1178=head2 fetchObjectInfo($otype, $attributes, @filters)
1179
1180Return an hashref with attribute data for each object matching @filters.
1181
1182If C<$attributes> can be an array ref to a list of attributes.
1183
1184=cut
1185
1186sub fetchObjectInfo {
1187    my ($self, $otype, $attributes, @filters) = @_;
1188
1189    my %results = map { $_ => {} }  $self->search_objects($otype, @filters);
1190
1191    foreach my $attr ( ref $attributes ? @$attributes : $attributes) {
1192        my %res = $self->attributes_summary_by_object($otype, $attr);
1193        foreach my $obj (keys %results) {
1194            $results{$obj}{$attr} = $res{$obj};
1195        }
1196    }
1197
1198    \%results;
1199}
1200
1201=head2 find_next_numeric_id($otype, $field, $min, $max)
1202
1203Return, if possible, next numeric id available (typically unix user UID).
1204
1205=cut
1206
1207sub find_next_numeric_id {
1208    my ($self, $otype, $field, $min, $max) = @_;
1209    my $pclass = $self->_load_obj_class($otype) or return;
1210    $pclass->find_next_numeric_id($self, $field, $min, $max);
1211}
1212
1213=head2 authenticate_user($username, $passwd)
1214
1215Return true if authentication success.
1216
1217Must be override by driver if the base have a proper authentication method
1218
1219=cut
1220
1221sub authenticate_user {
1222    my ($self, $username, $passwd) = @_;
1223    $username or return;
1224    my $uobj = $self->get_object('user', $username) or do {
1225        la_log(LA_ERR, "Cannot authenticate non existing user $username");
1226        return;
1227    };
1228
1229    $uobj->Authenticate( $passwd );
1230}
1231
1232=head2 passCrypt($clear_pass)
1233
1234Return an encrypted password using method set in config
1235
1236=cut
1237
1238sub passCrypt {
1239    my ($self, $clear_pass) = @_;
1240
1241    my $method = $self->config('crypt_method');
1242
1243    LATMOS::Accounts::Utils::Crypt($clear_pass, $method);
1244}
1245
1246=head2 SetConnectedUser($username)
1247
1248Set the username of the connected user
1249
1250=cut
1251
1252sub SetConnectedUser {
1253    my ($self, $username) = @_;
1254
1255    if ( $username ) {
1256        my $uobj = $self->get_object('user', $username) or do {
1257            la_log(LA_ERR, "Cannot authenticate non existing user $username");
1258            return;
1259        };
1260    }
1261
1262    $self->{_user} = $username || '';
1263    la_log(LA_DEBUG, "Connected as `" . $self->{_user} . "'");
1264}
1265
1266=head2 connect($username, $password)
1267
1268Authenticate the user and store the username as connected
1269
1270=cut
1271
1272sub connect {
1273    my ($self, $username, $password) = @_;
1274    my $auth = $self->authenticate_user($username, $password);
1275    if ($auth) {
1276        $self->SetConnectedUser($username);
1277    }
1278    return $auth;
1279}
1280
1281=head2 user
1282
1283Return the current connected username
1284
1285=cut
1286
1287sub user { $_[0]->{_user} }
1288
1289=head2 LogUser
1290
1291Return the username to use when no user is connected
1292
1293=cut
1294
1295sub LogUser {
1296    my ( $self ) = @_;
1297
1298    return $self->user || $self->la->LogUser;
1299}
1300
1301=head2 check_acl($obj, $attr, $perm)
1302
1303Return true if connected user have C<$perm> permission on attribute C<$attr> of
1304object C<$obj>.
1305
1306=cut
1307
1308sub check_acl {
1309    my ($self, $obj, $attr, $perm) = @_;
1310    if ($self->{_acls}) {
1311        my ($who, $groups) = ($self->user || '');
1312
1313        $self->{_acl_cache}{uid} ||= '';
1314
1315        if ($self->{_acl_cache}{uid} ne $who) {
1316            $self->{_acl_cache}{uid} = $who;
1317            my $uo = $self->get_object('user', $who);
1318            $self->{_acl_cache}{obj} = $uo;
1319            if ($uo) {
1320                $self->{_acl_cache}{groups} = [ $uo->_get_attributes('memberOf') ];
1321            }
1322        }
1323
1324        if ($who && (my $uo = $self->{_acl_cache}{obj})) {
1325            $groups = $self->{_acl_cache}{groups};
1326        } elsif (substr($who, 0, 1) eq '@') {
1327            # special account
1328            # only @ROOT should reach here
1329        } else {
1330            $who = '';
1331        }
1332        my $res = $self->{_acls}->check($obj, $attr, $perm, $who, $groups, $self);
1333        $self->log(LA_INFO, 'permission denied for "%s" to get %s.%s for %s',
1334           $who, ref $obj ? $obj->id . '(' . $obj->type . ')' : $obj, $attr, $perm) if (!$res);
1335        return $res;
1336    } else {
1337        # No acls, woot
1338        return 1;
1339    }
1340}
1341
1342=head2 text_empty_dump($fh, $otype, $options)
1343
1344Empty object dump
1345
1346=cut
1347
1348sub text_empty_dump {
1349    my ($self, $fh, $otype, $options) = @_;
1350    my $pclass = $self->_load_obj_class($otype) or return;
1351    $pclass->text_dump($fh, $options, $self);
1352}
1353
1354=head2 QFunc( $sub, @args )
1355
1356Compute function given in queryformat/search
1357
1358=cut
1359
1360sub QFunc {
1361    my ($self, $sub, $args) = @_;
1362
1363    $args ||= '';
1364    my @args = split(',', $args);
1365
1366    for ($sub) {
1367        /^now$/ and return DateTime->now( time_zone => 'local' )->iso8601;
1368    }
1369
1370    return '';
1371}
1372
13731;
1374
1375__END__
1376
1377=head1 SEE ALSO
1378
1379=head1 AUTHOR
1380
1381Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.fr<gt>
1382
1383=head1 COPYRIGHT AND LICENSE
1384
1385Copyright (C) 2009 by Thauvin Olivier
1386
1387This library is free software; you can redistribute it and/or modify
1388it under the same terms as Perl itself, either Perl version 5.10.0 or,
1389at your option, any later version of Perl 5 you may have available.
1390
1391=cut
Note: See TracBrowser for help on using the repository browser.