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

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

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