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

Last change on this file since 2456 was 2456, checked in by nanardon, 3 years ago

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