[2] | 1 | package LATMOS::Accounts::Bases; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | use LATMOS::Accounts::Bases::Objects; |
---|
[852] | 7 | use LATMOS::Accounts::Bases::Attributes; |
---|
[210] | 8 | use LATMOS::Accounts::Log; |
---|
[2041] | 9 | use LATMOS::Accounts::Utils qw( exec_command to_ascii ); |
---|
[2233] | 10 | use DateTime; |
---|
[2] | 11 | |
---|
[2356] | 12 | our $VERSION = (q$Rev: 2156 $ =~ /^Rev: (\d+) /)[0]; |
---|
[2] | 13 | |
---|
[3] | 14 | =head1 NAME |
---|
| 15 | |
---|
| 16 | LATMOS::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 | |
---|
| 26 | This module provide basic functions for various account base |
---|
| 27 | |
---|
[1070] | 28 | =head1 FUNCTIONS |
---|
[3] | 29 | |
---|
| 30 | =cut |
---|
| 31 | |
---|
| 32 | =head2 new($type, %options) |
---|
| 33 | |
---|
| 34 | Return, if success, a new data base account object, $type is |
---|
| 35 | account base type, %options to setup the base. |
---|
| 36 | |
---|
| 37 | =cut |
---|
| 38 | |
---|
[2] | 39 | sub new { |
---|
[1071] | 40 | my ($class, $type, $options) = @_; |
---|
[2] | 41 | |
---|
| 42 | my $pclass = ucfirst(lc($type)); |
---|
| 43 | eval "require LATMOS::Accounts::Bases::$pclass;"; |
---|
[1223] | 44 | if ($@) { |
---|
| 45 | la_log(LA_DEBUG, "Failed to load base type `%s': %s", $type, $@); |
---|
| 46 | return |
---|
| 47 | } |
---|
[1071] | 48 | my $base = "LATMOS::Accounts::Bases::$pclass"->new(%{$options->{params}}) |
---|
[1039] | 49 | or return; |
---|
[2261] | 50 | |
---|
| 51 | $options->{params}{monitored} ||= {}; |
---|
| 52 | |
---|
[41] | 53 | $base->{_type} = lc($pclass); |
---|
[1071] | 54 | $base->{_label} = $options->{label}; |
---|
| 55 | $base->{_options} = $options->{params}; |
---|
[282] | 56 | $base->{wexported} = 0; |
---|
[1071] | 57 | $base->{defattr} = $options->{defattr}; |
---|
| 58 | $base->{_acls} = $options->{acls}; |
---|
| 59 | $base->{_allowed_values} = $options->{allowed_values}; |
---|
| 60 | $base->{_la} = $options->{la}; |
---|
[2281] | 61 | |
---|
[2461] | 62 | $base->{defattr}{'user.min_uid'} ||= 1000; |
---|
| 63 | $base->{defattr}{'group.min_gid'} ||= 1000; |
---|
[2460] | 64 | |
---|
[2316] | 65 | # Callback, the list bellow give the supported callback |
---|
| 66 | $base->{_cb} = $options->{cb} || { |
---|
| 67 | commit => undef, |
---|
| 68 | postcommit => undef, |
---|
| 69 | }; |
---|
| 70 | |
---|
[2281] | 71 | $base->SetConnectedUser($ENV{LA_USERNAME}) if ($ENV{LA_USERNAME}); |
---|
| 72 | |
---|
[1071] | 73 | la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($base->label || 'N/A'), $pclass); |
---|
[41] | 74 | $base |
---|
[2] | 75 | } |
---|
| 76 | |
---|
[2316] | 77 | =head2 SetCallBack( $cb, $code ) |
---|
| 78 | |
---|
| 79 | Set callbalc $<cb> to function C<$code>. |
---|
| 80 | |
---|
| 81 | =cut |
---|
| 82 | |
---|
| 83 | sub 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 | |
---|
| 93 | Set callback $<cb> to function C<$code>. |
---|
| 94 | |
---|
| 95 | =cut |
---|
| 96 | |
---|
| 97 | sub GetCallBack { |
---|
| 98 | my ( $self, $cb ) = @_; |
---|
| 99 | |
---|
| 100 | if (exists ($self->{_cb}{$cb})) { |
---|
| 101 | $self->{_cb}{$cb} || sub { 1; }; |
---|
| 102 | } |
---|
| 103 | } |
---|
| 104 | |
---|
[1307] | 105 | =head2 load |
---|
| 106 | |
---|
| 107 | Make account base loading data into memory if need. |
---|
| 108 | Should 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 |
---|
| 114 | sub load { 1 } |
---|
| 115 | |
---|
| 116 | =head2 label |
---|
| 117 | |
---|
| 118 | Return the database label |
---|
| 119 | |
---|
| 120 | =cut |
---|
| 121 | |
---|
| 122 | sub label { |
---|
| 123 | $_[0]->{_label} || 'NoLabel'; |
---|
| 124 | } |
---|
| 125 | |
---|
| 126 | =head2 type |
---|
| 127 | |
---|
| 128 | Return the type of the base |
---|
| 129 | |
---|
| 130 | =cut |
---|
| 131 | |
---|
| 132 | sub type { |
---|
| 133 | $_[0]->{_type}; |
---|
| 134 | } |
---|
| 135 | |
---|
| 136 | =head2 la |
---|
| 137 | |
---|
| 138 | return LATMOS::Accounts object parent to the base |
---|
| 139 | |
---|
| 140 | =cut |
---|
| 141 | |
---|
| 142 | sub la { $_[0]->{_la} }; |
---|
| 143 | |
---|
| 144 | =head2 config ($opt) |
---|
| 145 | |
---|
| 146 | Return options from config |
---|
| 147 | |
---|
| 148 | =cut |
---|
| 149 | |
---|
| 150 | sub config { |
---|
[2156] | 151 | my ($self, $opt, $default) = @_; |
---|
| 152 | return defined($self->{_options}{$opt}) ? $self->{_options}{$opt} : $default; |
---|
[1307] | 153 | } |
---|
| 154 | |
---|
[1023] | 155 | =head2 wexported |
---|
| 156 | |
---|
| 157 | See L</unexported> |
---|
| 158 | |
---|
| 159 | =cut |
---|
| 160 | |
---|
[849] | 161 | sub wexported { unexported(@_) } |
---|
| 162 | |
---|
[1023] | 163 | =head2 unexported ($wexported) |
---|
| 164 | |
---|
| 165 | Set base to report unexported object or not |
---|
| 166 | |
---|
| 167 | =cut |
---|
| 168 | |
---|
[849] | 169 | sub unexported { |
---|
[282] | 170 | my ($self, $wexported) = @_; |
---|
| 171 | my $old = $self->{wexported}; |
---|
[284] | 172 | if (defined($wexported)) { |
---|
| 173 | $self->{wexported} = $wexported; |
---|
[285] | 174 | $self->log(LA_DEBUG, "Switching exported mode: %s => %s", $old, |
---|
[284] | 175 | $wexported); |
---|
| 176 | } |
---|
[282] | 177 | return($old || 0); |
---|
| 178 | } |
---|
| 179 | |
---|
[1182] | 180 | =head2 temp_switch_unexported($CODE, $value) |
---|
| 181 | |
---|
| 182 | Switch the base to unexported mode given by C<$value>, run C<$CODE>, restore |
---|
| 183 | back the previous state and return the result of code ref. |
---|
| 184 | |
---|
| 185 | =cut |
---|
| 186 | |
---|
| 187 | sub 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 | |
---|
[861] | 196 | =head2 log($level, $msg, $arg) |
---|
| 197 | |
---|
| 198 | Log a message prefixed by database information |
---|
| 199 | |
---|
| 200 | =cut |
---|
| 201 | |
---|
[274] | 202 | sub log { |
---|
| 203 | my ($self, $level, $msg, @args) = @_; |
---|
[304] | 204 | my $prefix = 'Base(' . $self->type . '/' . $self->label . ')'; |
---|
[274] | 205 | LATMOS::Accounts::Log::la_log($level, "$prefix $msg", @args); |
---|
| 206 | } |
---|
| 207 | |
---|
[1293] | 208 | =head2 ReportChange($otype, $name, $ref, $changetype, $message, @args) |
---|
[1286] | 209 | |
---|
| 210 | Functions to report back |
---|
| 211 | |
---|
| 212 | =cut |
---|
| 213 | |
---|
[1307] | 214 | sub ReportChange {} |
---|
[1286] | 215 | |
---|
[41] | 216 | =head2 list_supported_objects(@otype) |
---|
| 217 | |
---|
| 218 | Return a list of supported object |
---|
| 219 | |
---|
| 220 | @type is an additionnal list of objects to check |
---|
| 221 | |
---|
| 222 | =cut |
---|
| 223 | |
---|
| 224 | sub list_supported_objects { |
---|
| 225 | my ($self, @otype) = @_; |
---|
[146] | 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); |
---|
[210] | 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; |
---|
[41] | 240 | } |
---|
| 241 | |
---|
[1992] | 242 | =head2 ListSubObjectOType($otype) |
---|
| 243 | |
---|
| 244 | Return a list of sub object type supported by C<otype> objects. |
---|
| 245 | |
---|
| 246 | =cut |
---|
| 247 | |
---|
| 248 | sub 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 | |
---|
| 260 | Return the key linking sub object C<$sotype> to object type C<$otype> |
---|
| 261 | |
---|
| 262 | =cut |
---|
| 263 | |
---|
| 264 | sub 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 | |
---|
[1023] | 275 | =head2 ordered_objects |
---|
| 276 | |
---|
| 277 | Return supported object type ordered in best order for synchronisation |
---|
| 278 | |
---|
| 279 | =cut |
---|
| 280 | |
---|
[861] | 281 | sub 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; |
---|
[2405] | 291 | $attr->delayed and next; |
---|
[861] | 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 | |
---|
| 321 | sub _load_obj_class { |
---|
| 322 | my ($self, $otype) = @_; |
---|
| 323 | |
---|
[1317] | 324 | $otype or die "No type given: " . join(', ', caller) . "\n"; |
---|
[861] | 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 | |
---|
[41] | 337 | =head2 is_supported_object($otype) |
---|
| 338 | |
---|
| 339 | Return true is object type $otype is supported |
---|
| 340 | |
---|
| 341 | =cut |
---|
| 342 | |
---|
| 343 | sub is_supported_object { |
---|
| 344 | my ($self, $otype) = @_; |
---|
[892] | 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 | } |
---|
[41] | 355 | } |
---|
| 356 | |
---|
[1865] | 357 | =head2 list_objects($otype, %options) |
---|
[28] | 358 | |
---|
| 359 | Return the list of UID for object of $otype. |
---|
| 360 | |
---|
| 361 | =cut |
---|
| 362 | |
---|
| 363 | sub list_objects { |
---|
| 364 | my ($self, $otype) = @_; |
---|
| 365 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 366 | $pclass->list($self); |
---|
| 367 | } |
---|
| 368 | |
---|
[1865] | 369 | =head2 listRealObjects |
---|
| 370 | |
---|
| 371 | Return the list of UID for object of $otype, alias objects are not return |
---|
| 372 | |
---|
| 373 | Options depend of database support |
---|
| 374 | |
---|
| 375 | =cut |
---|
| 376 | |
---|
| 377 | sub listRealObjects { |
---|
| 378 | my ($self, $otype) = @_; |
---|
| 379 | $self->list_objects($otype); |
---|
| 380 | } |
---|
| 381 | |
---|
[3] | 382 | =head2 get_object($type, $id) |
---|
| 383 | |
---|
| 384 | Return an object of $type (typically user or group) having identifier |
---|
| 385 | $id. |
---|
| 386 | |
---|
| 387 | =cut |
---|
| 388 | |
---|
[2] | 389 | sub get_object { |
---|
| 390 | my ($self, $otype, $id) = @_; |
---|
| 391 | |
---|
[1865] | 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; |
---|
[2] | 406 | } |
---|
| 407 | |
---|
[1307] | 408 | =head2 create_c_object($type, $id, %data) |
---|
| 409 | |
---|
| 410 | Create and return an object of type $type with unique id |
---|
| 411 | $id having %data using canonical fields |
---|
| 412 | |
---|
| 413 | =cut |
---|
| 414 | |
---|
| 415 | sub 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 | |
---|
| 426 | sub _create_c_object { |
---|
| 427 | my ($self, $otype, $id, %cdata) = @_; |
---|
| 428 | |
---|
| 429 | $id ||= ''; # Avoid undef |
---|
| 430 | |
---|
| 431 | if (my $chk = ( |
---|
[2390] | 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) |
---|
[1307] | 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 | |
---|
[2352] | 439 | my %data; |
---|
| 440 | |
---|
[1307] | 441 | # populating default value |
---|
| 442 | { |
---|
| 443 | my %default = $self->compute_default($otype, $id, %cdata); |
---|
| 444 | foreach my $k (keys %default) { |
---|
[2357] | 445 | my $attr = $self->attribute($otype, $k) or next; |
---|
| 446 | $attr->ro and next; |
---|
[2352] | 447 | $data{$k} = $default{$k}; |
---|
[1307] | 448 | } |
---|
| 449 | } |
---|
| 450 | |
---|
[2352] | 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 | |
---|
[2360] | 464 | my $text = join("\n", $template->_get_attributes('data')); |
---|
[2352] | 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 | |
---|
[1992] | 475 | my $sub; |
---|
[1307] | 476 | foreach my $cfield (keys %cdata) { |
---|
[1992] | 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 | } |
---|
[1307] | 487 | } |
---|
[1992] | 488 | |
---|
[2356] | 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 | |
---|
[1307] | 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 | |
---|
[1992] | 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 | |
---|
[1307] | 539 | $obj |
---|
| 540 | } |
---|
| 541 | |
---|
[16] | 542 | =head2 create_object($type, $id, %data) |
---|
| 543 | |
---|
| 544 | Create and return an object of type $type with unique id |
---|
| 545 | $id having %data. |
---|
| 546 | |
---|
| 547 | This method should be provided by the data base handler. |
---|
| 548 | |
---|
| 549 | =cut |
---|
| 550 | |
---|
| 551 | sub create_object { |
---|
| 552 | my ($self, $otype, $id, %data) = @_; |
---|
[1974] | 553 | |
---|
[861] | 554 | "$id" or do { |
---|
[2384] | 555 | $self->log(LA_ERR, "Cannot create %s object with empty id", |
---|
[861] | 556 | $otype); |
---|
| 557 | return; |
---|
| 558 | }; |
---|
[1104] | 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 | }; |
---|
[1500] | 564 | |
---|
| 565 | if (!$pclass->checkValues($self, $id, %data)) { |
---|
[1545] | 566 | my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR); |
---|
[1500] | 567 | la_log(LA_ERR, |
---|
[1545] | 568 | 'Cannot create %s (%s) in base %s (%s): wrong value%s', |
---|
| 569 | $id, $otype, $self->label, $self->type, |
---|
| 570 | ($last ? ": $last" : ''), |
---|
[1500] | 571 | ); |
---|
| 572 | return; |
---|
| 573 | } |
---|
| 574 | |
---|
[257] | 575 | if ($pclass->_create($self, $id, %data)) { |
---|
| 576 | la_log(LA_INFO, |
---|
| 577 | 'Object %s (%s) created in base %s (%s)', |
---|
[1594] | 578 | $id, $otype, $self->label, $self->type, |
---|
[257] | 579 | ); |
---|
| 580 | } else { |
---|
[1594] | 581 | my $last = LATMOS::Accounts::Log::lastmessage(LA_ERR); |
---|
[212] | 582 | la_log(LA_ERR, |
---|
[1594] | 583 | 'Object creation %s (%s) in base %s (%s) failed%s', |
---|
| 584 | $id, $otype, $self->label, $self->type, |
---|
| 585 | ($last ? ": $last" : ''), |
---|
[210] | 586 | ); |
---|
[197] | 587 | return; |
---|
| 588 | }; |
---|
[1503] | 589 | |
---|
[27] | 590 | $self->get_object($otype, $id); |
---|
[16] | 591 | } |
---|
| 592 | |
---|
[1530] | 593 | =head2 defaultAttributeValue($otype, $attr) |
---|
[16] | 594 | |
---|
[1530] | 595 | Return default static value for attribute C<$attr> |
---|
| 596 | |
---|
| 597 | =cut |
---|
| 598 | |
---|
| 599 | sub defaultAttributeValue { |
---|
| 600 | my ($self, $otype, $attr) = @_; |
---|
| 601 | |
---|
| 602 | my %def = %{ $self->{defattr} || {}}; |
---|
| 603 | return $def{"$otype.$attr"} || ''; |
---|
| 604 | } |
---|
| 605 | |
---|
[1076] | 606 | =head2 compute_default($otype, $id, %cdata) |
---|
| 607 | |
---|
| 608 | Return a hash containing value to set for new object |
---|
| 609 | |
---|
| 610 | =cut |
---|
| 611 | |
---|
| 612 | sub compute_default { |
---|
[861] | 613 | my ($self, $otype, $id, %cdata) = @_; |
---|
[959] | 614 | |
---|
[1076] | 615 | my %default; |
---|
[365] | 616 | foreach my $def (keys %{ $self->{defattr} || {}}) { |
---|
[137] | 617 | if ($def =~ /^$otype\.(.*)$/) { |
---|
[1076] | 618 | $default{$1} = $self->{defattr}{$def} if(!$cdata{$1}); |
---|
[137] | 619 | } |
---|
| 620 | } |
---|
[1076] | 621 | |
---|
| 622 | # computed default value (not a simple set) |
---|
[598] | 623 | if (lc($otype) eq 'user') { |
---|
[1076] | 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', |
---|
[137] | 632 | $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'}); |
---|
[1076] | 633 | } |
---|
| 634 | |
---|
[765] | 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; |
---|
[2441] | 640 | if ($mailid) { |
---|
| 641 | $mailid =~ s/\s+/-/g; |
---|
| 642 | $mailid =~ s/['"]//g; |
---|
| 643 | } |
---|
[765] | 644 | |
---|
| 645 | if ($mailid && |
---|
| 646 | $self->is_supported_object('aliases') && |
---|
| 647 | ! $self->get_object('aliases', $mailid)) { |
---|
[861] | 648 | if (my $attr = $self->attribute($otype, 'mail')) { |
---|
| 649 | if ((!$attr->ro) && $self->{defattr}{'user.maildomain'}) { |
---|
[1076] | 650 | $default{mail} ||= sprintf('%s@%s', |
---|
[765] | 651 | $mailid, |
---|
| 652 | $self->{defattr}{'user.maildomain'}); |
---|
| 653 | } |
---|
| 654 | } |
---|
[861] | 655 | if (my $attr = $self->attribute($otype, 'aliases')) { |
---|
[1076] | 656 | $default{aliases} ||= $mailid unless ($attr->ro); |
---|
[765] | 657 | } |
---|
[861] | 658 | if (my $attr = $self->attribute($otype, 'revaliases')) { |
---|
[1076] | 659 | $default{revaliases} ||= $mailid unless ($attr->ro); |
---|
[765] | 660 | } |
---|
| 661 | } |
---|
[598] | 662 | } elsif (lc($otype) eq 'group') { |
---|
[1076] | 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 | } |
---|
[137] | 670 | } |
---|
[1076] | 671 | |
---|
| 672 | return %default; |
---|
| 673 | } |
---|
| 674 | |
---|
[861] | 675 | sub _allowed_values { |
---|
| 676 | $_[0]->{_allowed_values} |
---|
| 677 | } |
---|
| 678 | |
---|
[1023] | 679 | =head2 obj_attr_allowed_values ($otype, $attr) |
---|
| 680 | |
---|
| 681 | Return value allowed for this attribute |
---|
| 682 | |
---|
| 683 | =cut |
---|
| 684 | |
---|
[861] | 685 | sub 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 | |
---|
[1023] | 694 | =head2 check_allowed_values ($otype, $attr, $attrvalues) |
---|
| 695 | |
---|
| 696 | Check attributes C<$attr> of object type C<$otype> allow values C<$attrvalues> |
---|
| 697 | |
---|
| 698 | =cut |
---|
| 699 | |
---|
[861] | 700 | sub 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 | |
---|
| 721 | Return the list of supported fields by the database for object type $otype. |
---|
| 722 | |
---|
| 723 | Optionnal $for specify the goal for which the list is requested, only supported |
---|
| 724 | fields will be returns |
---|
| 725 | |
---|
| 726 | =cut |
---|
| 727 | |
---|
| 728 | sub 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 | |
---|
| 735 | sub _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 | |
---|
[1023] | 741 | =head2 get_attr_schema |
---|
| 742 | |
---|
| 743 | Deprecated |
---|
| 744 | |
---|
| 745 | =cut |
---|
| 746 | |
---|
| 747 | # TODO: kill this |
---|
| 748 | |
---|
[861] | 749 | sub 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 | |
---|
[1023] | 759 | =head2 attribute($otype, $attribute) |
---|
| 760 | |
---|
| 761 | Return attribute object. |
---|
| 762 | |
---|
| 763 | See L<LATMOS::Accounts::Bases::Attribute> |
---|
| 764 | |
---|
| 765 | =cut |
---|
| 766 | |
---|
[861] | 767 | sub attribute { |
---|
| 768 | my ($self, $otype, $attribute) = @_; |
---|
[1002] | 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 | |
---|
[861] | 779 | return LATMOS::Accounts::Bases::Attributes->new( |
---|
[1002] | 780 | $attrinfo, |
---|
[861] | 781 | $self, |
---|
| 782 | $otype, |
---|
| 783 | ); |
---|
| 784 | } |
---|
| 785 | |
---|
[1023] | 786 | =head2 delayed_fields |
---|
| 787 | |
---|
| 788 | DEPRECATED |
---|
| 789 | |
---|
| 790 | =cut |
---|
| 791 | |
---|
| 792 | # TODO: kill this |
---|
| 793 | |
---|
[861] | 794 | sub 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 | |
---|
[1023] | 809 | =head2 ochelper ($otype) |
---|
| 810 | |
---|
| 811 | Return L<LATMOS::Accounts::Bases::OChelper> object |
---|
| 812 | |
---|
| 813 | =cut |
---|
| 814 | |
---|
[861] | 815 | sub 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 | |
---|
[74] | 831 | =head2 delete_object($otype, $id) |
---|
| 832 | |
---|
| 833 | Destroy from data base object type $otype having id $id. |
---|
| 834 | |
---|
| 835 | =cut |
---|
| 836 | |
---|
| 837 | sub delete_object { |
---|
| 838 | my ($self, $otype, $id) = @_; |
---|
[488] | 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 | }; |
---|
[1286] | 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; |
---|
[488] | 855 | } |
---|
| 856 | |
---|
| 857 | sub _delete_object { |
---|
| 858 | my ($self, $otype, $id) = @_; |
---|
[74] | 859 | my $pclass = $self->_load_obj_class($otype); |
---|
[282] | 860 | $pclass->_delete($self, $id); |
---|
[74] | 861 | } |
---|
| 862 | |
---|
[715] | 863 | =head2 rename_object($otype, $id, $newid) |
---|
| 864 | |
---|
| 865 | Rename an object. |
---|
| 866 | |
---|
| 867 | =cut |
---|
| 868 | |
---|
| 869 | sub rename_object { |
---|
| 870 | my ($self, $otype, $id, $newid) = @_; |
---|
| 871 | |
---|
[1839] | 872 | $self->log(LA_DEBUG, "Trying to rename $otype/$id to $newid"); |
---|
[715] | 873 | my $obj = $self->get_object($otype, $id) or do { |
---|
[716] | 874 | $self->log(LA_WARN, 'Cannot rename %s/%s: no such object', |
---|
[715] | 875 | $otype, $id); |
---|
| 876 | return; |
---|
| 877 | }; |
---|
[716] | 878 | if (my $chk = (lc($otype) eq 'user' || lc($otype) eq 'group') |
---|
[1113] | 879 | ? LATMOS::Accounts::Utils::check_ug_validity($newid) |
---|
| 880 | : LATMOS::Accounts::Utils::check_oid_validity($newid)) { |
---|
[717] | 881 | $self->log(LA_ERR, "Cannot rename $otype/$id to ID $newid `%s:'", $chk); |
---|
[716] | 882 | return; |
---|
| 883 | } |
---|
[715] | 884 | $self->check_acl($obj, '@DELETE', 'w') && |
---|
[716] | 885 | $self->check_acl($obj, '@CREATE', 'w') or do { |
---|
| 886 | $self->log(LA_WARN, 'permission denied to rename %s/%s', |
---|
[715] | 887 | $otype, $id); |
---|
| 888 | return; |
---|
| 889 | }; |
---|
| 890 | |
---|
[1286] | 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; |
---|
[715] | 905 | } |
---|
| 906 | |
---|
| 907 | sub _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 | |
---|
[3] | 917 | =head2 is_transactionnal |
---|
[2] | 918 | |
---|
[3] | 919 | Return True is the database support commit and rollback |
---|
[2] | 920 | |
---|
[3] | 921 | =cut |
---|
[2] | 922 | |
---|
[3] | 923 | sub is_transactionnal { |
---|
| 924 | my ($self) = @_; |
---|
| 925 | return($self->can('_rollback') && $self->can('_commit')); |
---|
| 926 | } |
---|
[2] | 927 | |
---|
[3] | 928 | =head2 commit |
---|
[2] | 929 | |
---|
[3] | 930 | Save change into the database if change are not done immediately. |
---|
| 931 | This should always be called as you don't know when change are applied. |
---|
[2] | 932 | |
---|
[3] | 933 | Return always true if database does not support any transaction. |
---|
[2] | 934 | |
---|
[3] | 935 | The driver should provides a _commit functions to save data. |
---|
[2] | 936 | |
---|
[3] | 937 | =cut |
---|
[2] | 938 | |
---|
[3] | 939 | sub commit { |
---|
| 940 | my ($self) = @_; |
---|
[210] | 941 | if ($self->can('_commit')) { |
---|
| 942 | la_log(LA_DEBUG, 'Commiting data'); |
---|
[262] | 943 | if (!(my $res = $self->_commit)) { |
---|
[267] | 944 | la_log(LA_ERR, "Commit error on %s", $_->label); |
---|
[262] | 945 | return $res; |
---|
| 946 | } |
---|
[210] | 947 | } |
---|
[861] | 948 | |
---|
[2316] | 949 | $self->GetCallBack('commit')->(); |
---|
| 950 | |
---|
[861] | 951 | $self->postcommit(); |
---|
| 952 | |
---|
[264] | 953 | return 1; |
---|
[3] | 954 | } |
---|
[2] | 955 | |
---|
[1023] | 956 | =head2 postcommit |
---|
| 957 | |
---|
| 958 | Run postcommit command |
---|
| 959 | |
---|
| 960 | =cut |
---|
| 961 | |
---|
[861] | 962 | sub 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 | ); |
---|
[2316] | 974 | $self->GetCallBack('postcommit')->(); |
---|
[861] | 975 | } else { |
---|
| 976 | return 1; |
---|
| 977 | } |
---|
| 978 | } |
---|
| 979 | |
---|
[3] | 980 | =head2 rollback |
---|
[2] | 981 | |
---|
[3] | 982 | If database support transaction, rollback changes. Return false |
---|
| 983 | if database does not support. |
---|
[2] | 984 | |
---|
[3] | 985 | If supported, driver should provides a _rollback functions |
---|
[2] | 986 | |
---|
[3] | 987 | =cut |
---|
[2] | 988 | |
---|
[3] | 989 | sub rollback { |
---|
| 990 | my ($self) = @_; |
---|
[210] | 991 | if ($self->can('_rollback')) { |
---|
| 992 | la_log(LA_DEBUG, 'Rolling back data'); |
---|
| 993 | return $self->_rollback; |
---|
| 994 | } else { |
---|
| 995 | return 0; |
---|
| 996 | } |
---|
[3] | 997 | } |
---|
[2] | 998 | |
---|
[49] | 999 | =head2 current_rev |
---|
| 1000 | |
---|
| 1001 | Return the current revision of the database |
---|
| 1002 | |
---|
| 1003 | Must be provide by base driver if incremental synchro is supported |
---|
| 1004 | |
---|
| 1005 | =cut |
---|
| 1006 | |
---|
| 1007 | sub current_rev { return } |
---|
| 1008 | |
---|
| 1009 | =head2 list_objects_from_rev($otype, $rev) |
---|
| 1010 | |
---|
| 1011 | Return the list of UID for object of $otype. |
---|
| 1012 | |
---|
| 1013 | =cut |
---|
| 1014 | |
---|
| 1015 | sub 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 | |
---|
[1023] | 1026 | =head2 sync_object_from($srcbase, $otype, $id, %options) |
---|
| 1027 | |
---|
| 1028 | Sync object type C<$otype> C<$id> from base C<$srcbase> to current base. |
---|
| 1029 | |
---|
| 1030 | C<%options>: |
---|
| 1031 | |
---|
| 1032 | =over 4 |
---|
| 1033 | |
---|
| 1034 | =item nodelete |
---|
| 1035 | |
---|
| 1036 | Don't delete object if the object synchronize don't exist in source base |
---|
| 1037 | |
---|
| 1038 | =back |
---|
| 1039 | |
---|
| 1040 | =cut |
---|
| 1041 | |
---|
[532] | 1042 | sub 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}) { |
---|
[540] | 1053 | $self->_delete_object($otype, $id) and return 'DELETED'; |
---|
[532] | 1054 | } |
---|
| 1055 | return; |
---|
| 1056 | } |
---|
| 1057 | |
---|
[83] | 1058 | =head2 sync_object |
---|
| 1059 | |
---|
| 1060 | Synchronise an object into this base |
---|
| 1061 | |
---|
| 1062 | =cut |
---|
| 1063 | |
---|
| 1064 | sub sync_object { |
---|
| 1065 | my ($self, $srcobj, %options) = @_; |
---|
[105] | 1066 | $self->is_supported_object($srcobj->type) or return ''; |
---|
[83] | 1067 | my @fields = $options{attrs} |
---|
| 1068 | ? @{ $options{attrs} } |
---|
[103] | 1069 | : $self->list_canonical_fields($srcobj->type, 'w'); |
---|
[83] | 1070 | my %data; |
---|
| 1071 | foreach (@fields) { |
---|
[861] | 1072 | # check attribute exists in source: |
---|
[2427] | 1073 | my $attr = $srcobj->attribute($_) or next; |
---|
[2429] | 1074 | my $destattr = $self->attribute( $srcobj->type, $_ ) or next; |
---|
[933] | 1075 | $attr->readable or next; |
---|
[2430] | 1076 | $destattr->ro and next; |
---|
[777] | 1077 | if (! $options{onepass}) { |
---|
| 1078 | if ($options{firstpass}) { |
---|
[2429] | 1079 | $destattr->delayed and next; |
---|
[777] | 1080 | } else { |
---|
[2429] | 1081 | $destattr->delayed or next; |
---|
[777] | 1082 | } |
---|
[668] | 1083 | } |
---|
[1865] | 1084 | $data{$_} = $srcobj->GetAttributeValue($_); |
---|
[83] | 1085 | } |
---|
| 1086 | if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) { |
---|
[861] | 1087 | keys %data or return 'SYNCED'; |
---|
| 1088 | foreach (keys %data) { |
---|
| 1089 | if (!$dstobj->attribute($_) || |
---|
| 1090 | $dstobj->attribute($_)->ro) { |
---|
| 1091 | delete($data{$_}); |
---|
| 1092 | } |
---|
| 1093 | } |
---|
[355] | 1094 | my $res = $dstobj->_set_c_fields(%data); |
---|
| 1095 | if (defined $res) { |
---|
[661] | 1096 | return $res ? 'SYNCED' : ''; |
---|
[355] | 1097 | } else { |
---|
| 1098 | return; |
---|
| 1099 | } |
---|
[83] | 1100 | } elsif(!$options{nocreate}) { |
---|
[777] | 1101 | if ((! $options{firstpass}) && (!$options{onepass})) { |
---|
[775] | 1102 | $self->log(LA_ERR, 'This is not first pass, creation wanted but denied'); |
---|
| 1103 | return; |
---|
| 1104 | } |
---|
[1357] | 1105 | if (my $res = $self->_create_c_object($srcobj->type, $srcobj->id, %data)) { |
---|
[661] | 1106 | return 'CREATED' |
---|
[355] | 1107 | } else { |
---|
| 1108 | return; |
---|
| 1109 | } |
---|
[83] | 1110 | } else { |
---|
[197] | 1111 | # No error, but creation is denied |
---|
| 1112 | return 'Creation skipped'; |
---|
[83] | 1113 | } |
---|
[105] | 1114 | |
---|
| 1115 | return; |
---|
[83] | 1116 | } |
---|
| 1117 | |
---|
[1235] | 1118 | =head2 search_objects($otype, @filter) |
---|
[122] | 1119 | |
---|
[1235] | 1120 | Search object according @filter. @filter is a list |
---|
[122] | 1121 | of field/value which should match. |
---|
| 1122 | |
---|
| 1123 | A default function is provided but each db driver can provide |
---|
| 1124 | an optimize version. |
---|
| 1125 | |
---|
| 1126 | =cut |
---|
| 1127 | |
---|
| 1128 | sub search_objects { |
---|
[326] | 1129 | my ($self, $otype, @filter) = @_; |
---|
[122] | 1130 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
[326] | 1131 | $pclass->search($self, @filter); |
---|
[122] | 1132 | } |
---|
| 1133 | |
---|
[1023] | 1134 | =head2 attributes_summary($otype, $attr) |
---|
| 1135 | |
---|
| 1136 | Return couple object id / value for attribute C<$attr> of object type C<$otype> |
---|
| 1137 | |
---|
| 1138 | This method is designed to be faster than fetching object one by one. |
---|
| 1139 | |
---|
| 1140 | =cut |
---|
| 1141 | |
---|
[257] | 1142 | sub 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 | |
---|
[1413] | 1148 | =head2 attributes_summary_by_object($otype, $attr) |
---|
[1412] | 1149 | |
---|
| 1150 | Return couple object id / value for attribute C<$attr> of object type C<$otype> |
---|
| 1151 | |
---|
| 1152 | This method is designed to be faster than fetching object one by one. |
---|
| 1153 | |
---|
| 1154 | =cut |
---|
| 1155 | |
---|
| 1156 | sub 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 | |
---|
[1694] | 1162 | =head2 fetchObjectInfo($otype, $attributes, @filters) |
---|
| 1163 | |
---|
| 1164 | Return an hashref with attribute data for each object matching @filters. |
---|
| 1165 | |
---|
| 1166 | If C<$attributes> can be an array ref to a list of attributes. |
---|
| 1167 | |
---|
| 1168 | =cut |
---|
| 1169 | |
---|
| 1170 | sub 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 | |
---|
[1023] | 1185 | =head2 find_next_numeric_id($otype, $field, $min, $max) |
---|
| 1186 | |
---|
| 1187 | Return, if possible, next numeric id available (typically unix user UID). |
---|
| 1188 | |
---|
| 1189 | =cut |
---|
| 1190 | |
---|
[137] | 1191 | sub 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 | |
---|
[1023] | 1197 | =head2 authenticate_user($username, $passwd) |
---|
| 1198 | |
---|
| 1199 | Return true if authentication success. |
---|
| 1200 | |
---|
| 1201 | Must be override by driver if the base have a proper authentication method |
---|
| 1202 | |
---|
| 1203 | =cut |
---|
| 1204 | |
---|
[231] | 1205 | sub 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 | }; |
---|
[671] | 1212 | |
---|
[2456] | 1213 | $uobj->Authenticate( $passwd ); |
---|
[231] | 1214 | } |
---|
| 1215 | |
---|
[2041] | 1216 | =head2 passCrypt($clear_pass) |
---|
| 1217 | |
---|
| 1218 | Return an encrypted password using method set in config |
---|
| 1219 | |
---|
| 1220 | =cut |
---|
| 1221 | |
---|
| 1222 | sub 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 | |
---|
[2278] | 1230 | =head2 SetConnectedUser($username) |
---|
| 1231 | |
---|
| 1232 | Set the username of the connected user |
---|
| 1233 | |
---|
| 1234 | =cut |
---|
| 1235 | |
---|
| 1236 | sub SetConnectedUser { |
---|
| 1237 | my ($self, $username) = @_; |
---|
| 1238 | |
---|
[2282] | 1239 | $self->{_user} = $username || ''; |
---|
| 1240 | la_log(LA_DEBUG, "Connected as `$username'"); |
---|
[2278] | 1241 | } |
---|
| 1242 | |
---|
[1023] | 1243 | =head2 connect($username, $password) |
---|
| 1244 | |
---|
| 1245 | Authenticate the user and store the username as connected |
---|
| 1246 | |
---|
| 1247 | =cut |
---|
| 1248 | |
---|
[320] | 1249 | sub connect { |
---|
| 1250 | my ($self, $username, $password) = @_; |
---|
| 1251 | my $auth = $self->authenticate_user($username, $password); |
---|
| 1252 | if ($auth) { |
---|
[2278] | 1253 | $self->SetConnectedUser($username); |
---|
[320] | 1254 | } |
---|
| 1255 | return $auth; |
---|
| 1256 | } |
---|
| 1257 | |
---|
[1091] | 1258 | =head2 user |
---|
| 1259 | |
---|
| 1260 | Return the current connected username |
---|
| 1261 | |
---|
| 1262 | =cut |
---|
| 1263 | |
---|
| 1264 | sub user { $_[0]->{_user} } |
---|
| 1265 | |
---|
[2439] | 1266 | =head2 LogUser |
---|
| 1267 | |
---|
| 1268 | Return the username to use when no user is connected |
---|
| 1269 | |
---|
| 1270 | =cut |
---|
| 1271 | |
---|
| 1272 | sub LogUser { |
---|
| 1273 | my ( $self ) = @_; |
---|
| 1274 | |
---|
| 1275 | return $self->user || $self->la->LogUser; |
---|
| 1276 | } |
---|
| 1277 | |
---|
[1023] | 1278 | =head2 check_acl($obj, $attr, $perm) |
---|
| 1279 | |
---|
| 1280 | Return true if connected user have C<$perm> permission on attribute C<$attr> of |
---|
| 1281 | object C<$obj>. |
---|
| 1282 | |
---|
| 1283 | =cut |
---|
| 1284 | |
---|
[316] | 1285 | sub check_acl { |
---|
| 1286 | my ($self, $obj, $attr, $perm) = @_; |
---|
| 1287 | if ($self->{_acls}) { |
---|
[1091] | 1288 | my ($who, $groups) = ($self->user || ''); |
---|
[1731] | 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}; |
---|
[2381] | 1303 | } elsif (substr($who, 0, 1) eq '@') { |
---|
| 1304 | # special account |
---|
| 1305 | # only @ROOT should reach here |
---|
[470] | 1306 | } else { |
---|
| 1307 | $who = ''; |
---|
| 1308 | } |
---|
[2344] | 1309 | my $res = $self->{_acls}->check($obj, $attr, $perm, $who, $groups, $self); |
---|
[477] | 1310 | $self->log(LA_INFO, 'permission denied for "%s" to get %s.%s for %s', |
---|
[474] | 1311 | $who, ref $obj ? $obj->id . '(' . $obj->type . ')' : $obj, $attr, $perm) if (!$res); |
---|
[470] | 1312 | return $res; |
---|
[316] | 1313 | } else { |
---|
| 1314 | # No acls, woot |
---|
| 1315 | return 1; |
---|
| 1316 | } |
---|
| 1317 | } |
---|
[320] | 1318 | |
---|
[1023] | 1319 | =head2 text_empty_dump($fh, $otype, $options) |
---|
| 1320 | |
---|
| 1321 | Empty object dump |
---|
| 1322 | |
---|
| 1323 | =cut |
---|
| 1324 | |
---|
[339] | 1325 | sub 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 | |
---|
[2233] | 1331 | =head2 QFunc( $sub, @args ) |
---|
| 1332 | |
---|
| 1333 | Compute function given in queryformat/search |
---|
| 1334 | |
---|
| 1335 | =cut |
---|
| 1336 | |
---|
| 1337 | sub QFunc { |
---|
[2234] | 1338 | my ($self, $sub, $args) = @_; |
---|
[2233] | 1339 | |
---|
[2234] | 1340 | $args ||= ''; |
---|
| 1341 | my @args = split(',', $args); |
---|
| 1342 | |
---|
[2233] | 1343 | for ($sub) { |
---|
| 1344 | /^now$/ and return DateTime->now->iso8601; |
---|
| 1345 | } |
---|
| 1346 | |
---|
| 1347 | return ''; |
---|
| 1348 | } |
---|
| 1349 | |
---|
[3] | 1350 | 1; |
---|
[2] | 1351 | |
---|
[3] | 1352 | __END__ |
---|
[2] | 1353 | |
---|
[3] | 1354 | =head1 SEE ALSO |
---|
[2] | 1355 | |
---|
| 1356 | =head1 AUTHOR |
---|
| 1357 | |
---|
[17] | 1358 | Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.fr<gt> |
---|
[2] | 1359 | |
---|
| 1360 | =head1 COPYRIGHT AND LICENSE |
---|
| 1361 | |
---|
| 1362 | Copyright (C) 2009 by Thauvin Olivier |
---|
| 1363 | |
---|
| 1364 | This library is free software; you can redistribute it and/or modify |
---|
| 1365 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 1366 | at your option, any later version of Perl 5 you may have available. |
---|
| 1367 | |
---|
| 1368 | =cut |
---|