[2] | 1 | package LATMOS::Accounts::Bases; |
---|
| 2 | |
---|
| 3 | use 5.010000; |
---|
| 4 | use strict; |
---|
| 5 | use warnings; |
---|
| 6 | use LATMOS::Accounts::Bases::Objects; |
---|
[210] | 7 | use LATMOS::Accounts::Log; |
---|
[2] | 8 | |
---|
[3] | 9 | our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0]; |
---|
[2] | 10 | |
---|
[3] | 11 | =head1 NAME |
---|
| 12 | |
---|
| 13 | LATMOS::Accounts::Bases - Base class for account data bases |
---|
| 14 | |
---|
| 15 | =head1 SYNOPSIS |
---|
| 16 | |
---|
| 17 | use LATMOS::Accounts::Bases; |
---|
| 18 | my $base = LATMOS::Accounts::Bases->new('type', %options); |
---|
| 19 | ... |
---|
| 20 | |
---|
| 21 | =head1 DESCRIPTION |
---|
| 22 | |
---|
| 23 | This module provide basic functions for various account base |
---|
| 24 | |
---|
| 25 | =head1 FUNTIONS |
---|
| 26 | |
---|
| 27 | =cut |
---|
| 28 | |
---|
| 29 | =head2 new($type, %options) |
---|
| 30 | |
---|
| 31 | Return, if success, a new data base account object, $type is |
---|
| 32 | account base type, %options to setup the base. |
---|
| 33 | |
---|
| 34 | =cut |
---|
| 35 | |
---|
[2] | 36 | sub new { |
---|
| 37 | my ($class, $type, %options) = @_; |
---|
| 38 | |
---|
| 39 | my $pclass = ucfirst(lc($type)); |
---|
| 40 | eval "require LATMOS::Accounts::Bases::$pclass;"; |
---|
| 41 | if ($@) { return } # error message ? |
---|
[41] | 42 | my $base = "LATMOS::Accounts::Bases::$pclass"->new(%options); |
---|
| 43 | $base->{_type} = lc($pclass); |
---|
[49] | 44 | $base->{_label} = $options{label}; |
---|
[137] | 45 | $base->{defattr} = $options{defattr}; |
---|
[210] | 46 | la_log(LA_DEBUG, 'Instanciate base %s (%s)', ($options{label} || 'N/A'), $pclass); |
---|
[41] | 47 | $base |
---|
[2] | 48 | } |
---|
| 49 | |
---|
[49] | 50 | sub label { |
---|
| 51 | $_[0]->{_label}; |
---|
| 52 | } |
---|
| 53 | |
---|
[41] | 54 | sub type { |
---|
| 55 | $_[0]->{_type}; |
---|
| 56 | } |
---|
| 57 | |
---|
[6] | 58 | sub _load_obj_class { |
---|
| 59 | my ($self, $otype) = @_; |
---|
| 60 | |
---|
| 61 | # finding perl class: |
---|
| 62 | my $pclass = ref $self; |
---|
| 63 | $pclass .= '::' . ucfirst(lc($otype)); |
---|
| 64 | eval "require $pclass;"; |
---|
[210] | 65 | if ($@) { |
---|
| 66 | la_log(LA_DEBUG, 'Cannot load perl class %s', $pclass); |
---|
| 67 | return |
---|
| 68 | } # error message ? |
---|
[6] | 69 | return $pclass; |
---|
| 70 | } |
---|
| 71 | |
---|
[103] | 72 | =head2 list_canonical_fields($otype, $for) |
---|
[6] | 73 | |
---|
| 74 | Return the list of supported fields by the database for object type $otype. |
---|
| 75 | |
---|
[57] | 76 | Optionnal $for specify the goal for which the list is requested, only supported |
---|
| 77 | fields will be returns |
---|
| 78 | |
---|
[6] | 79 | =cut |
---|
| 80 | |
---|
[103] | 81 | sub list_canonical_fields { |
---|
[57] | 82 | my ($self, $otype, $for) = @_; |
---|
| 83 | $for ||= 'rw'; |
---|
[6] | 84 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
[201] | 85 | sort $pclass->_canonical_fields($self, $for); |
---|
[6] | 86 | } |
---|
| 87 | |
---|
[60] | 88 | sub delayed_fields { |
---|
| 89 | my ($self, $otype, $for) = @_; |
---|
| 90 | $for ||= 'rw'; |
---|
| 91 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 92 | $pclass->_delayed_fields($self, $for); |
---|
| 93 | } |
---|
| 94 | |
---|
[57] | 95 | =head2 get_field_name($otype, $c_fields, $for) |
---|
[7] | 96 | |
---|
| 97 | Return the internal fields name for $otype object for |
---|
| 98 | canonical fields $c_fields |
---|
| 99 | |
---|
| 100 | =cut |
---|
| 101 | |
---|
| 102 | sub get_field_name { |
---|
[57] | 103 | my ($self, $otype, $c_fields, $for) = @_; |
---|
[64] | 104 | $for ||= 'rw'; |
---|
[7] | 105 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
[57] | 106 | $pclass->_get_field_name($c_fields, $self, $for); |
---|
[7] | 107 | } |
---|
| 108 | |
---|
[41] | 109 | =head2 list_supported_objects(@otype) |
---|
| 110 | |
---|
| 111 | Return a list of supported object |
---|
| 112 | |
---|
| 113 | @type is an additionnal list of objects to check |
---|
| 114 | |
---|
| 115 | =cut |
---|
| 116 | |
---|
| 117 | sub list_supported_objects { |
---|
| 118 | my ($self, @otype) = @_; |
---|
[146] | 119 | my %res; |
---|
| 120 | foreach my $inc (@INC) { |
---|
| 121 | my $sub = 'LATMOS::Accounts::Bases::' . ucfirst($self->type); |
---|
| 122 | $sub =~ s/::/\//g; |
---|
| 123 | foreach (glob("$inc/$sub/[A-Z]*.pm")) { |
---|
| 124 | s/.*\///; |
---|
| 125 | s/\.pm$//; |
---|
| 126 | $res{lc($_)} = 1; |
---|
| 127 | } |
---|
| 128 | } |
---|
| 129 | $res{$_} = 1 foreach(@otype); |
---|
[210] | 130 | my @sobj = grep { $self->is_supported_object($_) } keys %res; |
---|
| 131 | la_log(LA_DEBUG, "Base %s supported objects: %s", $self->type, join(', ', @sobj)); |
---|
| 132 | return @sobj; |
---|
[41] | 133 | } |
---|
| 134 | |
---|
| 135 | =head2 is_supported_object($otype) |
---|
| 136 | |
---|
| 137 | Return true is object type $otype is supported |
---|
| 138 | |
---|
| 139 | =cut |
---|
| 140 | |
---|
| 141 | sub is_supported_object { |
---|
| 142 | my ($self, $otype) = @_; |
---|
| 143 | return $self->_load_obj_class($otype) ? 1 : 0; |
---|
| 144 | } |
---|
| 145 | |
---|
[28] | 146 | =head2 list_objects($otype) |
---|
| 147 | |
---|
| 148 | Return the list of UID for object of $otype. |
---|
| 149 | |
---|
| 150 | =cut |
---|
| 151 | |
---|
| 152 | sub list_objects { |
---|
| 153 | my ($self, $otype) = @_; |
---|
| 154 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 155 | $pclass->list($self); |
---|
| 156 | } |
---|
| 157 | |
---|
[3] | 158 | =head2 get_object($type, $id) |
---|
| 159 | |
---|
| 160 | Return an object of $type (typically user or group) having identifier |
---|
| 161 | $id. |
---|
| 162 | |
---|
| 163 | =cut |
---|
| 164 | |
---|
[2] | 165 | sub get_object { |
---|
| 166 | my ($self, $otype, $id) = @_; |
---|
| 167 | |
---|
[27] | 168 | return LATMOS::Accounts::Bases::Objects->_new($self, $otype, $id); |
---|
[2] | 169 | } |
---|
| 170 | |
---|
[16] | 171 | =head2 create_object($type, $id, %data) |
---|
| 172 | |
---|
| 173 | Create and return an object of type $type with unique id |
---|
| 174 | $id having %data. |
---|
| 175 | |
---|
| 176 | This method should be provided by the data base handler. |
---|
| 177 | |
---|
| 178 | =cut |
---|
| 179 | |
---|
| 180 | sub create_object { |
---|
| 181 | my ($self, $otype, $id, %data) = @_; |
---|
[27] | 182 | my $pclass = $self->_load_obj_class($otype); |
---|
[257] | 183 | if ($pclass->_create($self, $id, %data)) { |
---|
| 184 | la_log(LA_INFO, |
---|
| 185 | 'Object %s (%s) created in base %s (%s)', |
---|
| 186 | $id, $otype, $self->label, $self->type |
---|
| 187 | ); |
---|
| 188 | } else { |
---|
[212] | 189 | la_log(LA_ERR, |
---|
[210] | 190 | 'Object creation %s (%s) in base %s (%s) failed', |
---|
| 191 | $id, $otype, $self->label, $self->type |
---|
| 192 | ); |
---|
[197] | 193 | return; |
---|
| 194 | }; |
---|
[27] | 195 | $self->get_object($otype, $id); |
---|
[16] | 196 | } |
---|
| 197 | |
---|
| 198 | =head2 create_c_object($type, $id, %data) |
---|
| 199 | |
---|
| 200 | Create and return an object of type $type with unique id |
---|
| 201 | $id having %data using canonical fields |
---|
| 202 | |
---|
| 203 | =cut |
---|
| 204 | |
---|
| 205 | sub create_c_object { |
---|
| 206 | my ($self, $otype, $id, %cdata) = @_; |
---|
| 207 | |
---|
[137] | 208 | # populating default value |
---|
| 209 | foreach my $def (%{ $self->{defattr} || {}}) { |
---|
| 210 | if ($def =~ /^$otype\.(.*)$/) { |
---|
| 211 | $cdata{$1} = $self->{defattr}{$def} if(!$cdata{$1}); |
---|
| 212 | } |
---|
| 213 | } |
---|
| 214 | if ($otype eq 'user') { |
---|
[175] | 215 | $cdata{homeDirectory} ||= $self->{defattr}{'user.homebase'} ? |
---|
| 216 | $self->{defattr}{'user.homebase'} . "/$id" : ''; |
---|
[137] | 217 | $cdata{uidNumber} ||= $self->find_next_numeric_id('user', 'uidNumber', |
---|
| 218 | $self->{defattr}{'user.min_uid'}, $self->{defattr}{'user.max_uid'}); |
---|
| 219 | } elsif ($otype eq 'group') { |
---|
| 220 | $cdata{gidNumber} ||= $self->find_next_numeric_id('group', 'gidNumber', |
---|
| 221 | $self->{defattr}{'group.min_gid'}, $self->{defattr}{'group.max_gid'}); |
---|
| 222 | } |
---|
[16] | 223 | my %data; |
---|
| 224 | foreach my $cfield (keys %cdata) { |
---|
[57] | 225 | my $field = $self->get_field_name($otype, $cfield, 'write') or next; |
---|
[16] | 226 | $data{$field} = $cdata{$cfield}; |
---|
| 227 | } |
---|
[42] | 228 | keys %data or return 0; # TODO: return an error ? |
---|
[16] | 229 | $self->create_object($otype, $id, %data); |
---|
| 230 | } |
---|
| 231 | |
---|
[74] | 232 | =head2 delete_object($otype, $id) |
---|
| 233 | |
---|
| 234 | Destroy from data base object type $otype having id $id. |
---|
| 235 | |
---|
| 236 | =cut |
---|
| 237 | |
---|
| 238 | sub delete_object { |
---|
| 239 | my ($self, $otype, $id) = @_; |
---|
| 240 | my $pclass = $self->_load_obj_class($otype); |
---|
| 241 | $pclass->_delete($self, $id) or return; |
---|
| 242 | } |
---|
| 243 | |
---|
[5] | 244 | =head2 load |
---|
| 245 | |
---|
| 246 | Make account base loading data into memory if need. |
---|
| 247 | Should always be called, if database fetch data on the fly |
---|
| 248 | (SQL, LDAP), the function just return True. |
---|
| 249 | |
---|
| 250 | =cut |
---|
| 251 | |
---|
| 252 | sub load { 1 } |
---|
| 253 | |
---|
[3] | 254 | =head2 is_transactionnal |
---|
[2] | 255 | |
---|
[3] | 256 | Return True is the database support commit and rollback |
---|
[2] | 257 | |
---|
[3] | 258 | =cut |
---|
[2] | 259 | |
---|
[3] | 260 | sub is_transactionnal { |
---|
| 261 | my ($self) = @_; |
---|
| 262 | return($self->can('_rollback') && $self->can('_commit')); |
---|
| 263 | } |
---|
[2] | 264 | |
---|
[3] | 265 | =head2 commit |
---|
[2] | 266 | |
---|
[3] | 267 | Save change into the database if change are not done immediately. |
---|
| 268 | This should always be called as you don't know when change are applied. |
---|
[2] | 269 | |
---|
[3] | 270 | Return always true if database does not support any transaction. |
---|
[2] | 271 | |
---|
[3] | 272 | The driver should provides a _commit functions to save data. |
---|
[2] | 273 | |
---|
[3] | 274 | =cut |
---|
[2] | 275 | |
---|
[3] | 276 | sub commit { |
---|
| 277 | my ($self) = @_; |
---|
[210] | 278 | if ($self->can('_commit')) { |
---|
| 279 | la_log(LA_DEBUG, 'Commiting data'); |
---|
| 280 | return $self->_commit; |
---|
| 281 | } else { |
---|
| 282 | return 1; |
---|
| 283 | } |
---|
[3] | 284 | } |
---|
[2] | 285 | |
---|
[3] | 286 | =head2 rollback |
---|
[2] | 287 | |
---|
[3] | 288 | If database support transaction, rollback changes. Return false |
---|
| 289 | if database does not support. |
---|
[2] | 290 | |
---|
[3] | 291 | If supported, driver should provides a _rollback functions |
---|
[2] | 292 | |
---|
[3] | 293 | =cut |
---|
[2] | 294 | |
---|
[3] | 295 | sub rollback { |
---|
| 296 | my ($self) = @_; |
---|
[210] | 297 | if ($self->can('_rollback')) { |
---|
| 298 | la_log(LA_DEBUG, 'Rolling back data'); |
---|
| 299 | return $self->_rollback; |
---|
| 300 | } else { |
---|
| 301 | return 0; |
---|
| 302 | } |
---|
[3] | 303 | } |
---|
[2] | 304 | |
---|
[49] | 305 | =head2 current_rev |
---|
| 306 | |
---|
| 307 | Return the current revision of the database |
---|
| 308 | |
---|
| 309 | Must be provide by base driver if incremental synchro is supported |
---|
| 310 | |
---|
| 311 | =cut |
---|
| 312 | |
---|
| 313 | sub current_rev { return } |
---|
| 314 | |
---|
| 315 | =head2 list_objects_from_rev($otype, $rev) |
---|
| 316 | |
---|
| 317 | Return the list of UID for object of $otype. |
---|
| 318 | |
---|
| 319 | =cut |
---|
| 320 | |
---|
| 321 | sub list_objects_from_rev { |
---|
| 322 | my ($self, $otype, $rev) = @_; |
---|
| 323 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 324 | if (defined($rev) && $pclass->can('list_from_rev')) { |
---|
| 325 | return $pclass->list_from_rev($self, $rev); |
---|
| 326 | } else { |
---|
| 327 | # no support, return all objects... |
---|
| 328 | return $self->list_objects($otype); |
---|
| 329 | } |
---|
| 330 | } |
---|
| 331 | |
---|
[83] | 332 | =head2 sync_object |
---|
| 333 | |
---|
| 334 | Synchronise an object into this base |
---|
| 335 | |
---|
| 336 | =cut |
---|
| 337 | |
---|
| 338 | sub sync_object { |
---|
| 339 | my ($self, $srcobj, %options) = @_; |
---|
[105] | 340 | $self->is_supported_object($srcobj->type) or return ''; |
---|
[83] | 341 | my @fields = $options{attrs} |
---|
| 342 | ? @{ $options{attrs} } |
---|
[103] | 343 | : $self->list_canonical_fields($srcobj->type, 'w'); |
---|
[83] | 344 | my %data; |
---|
| 345 | foreach (@fields) { |
---|
[96] | 346 | $srcobj->get_field_name($_, 'r') or next; |
---|
[83] | 347 | $data{$_} = $srcobj->get_c_field($_); |
---|
| 348 | } |
---|
| 349 | if (my $dstobj = $self->get_object($srcobj->type, $srcobj->id)) { |
---|
[105] | 350 | return 'SYNCHED' if ($dstobj->set_c_fields(%data)); |
---|
[83] | 351 | } elsif(!$options{nocreate}) { |
---|
[105] | 352 | return 'CREATE' if ($self->create_c_object($srcobj->type, $srcobj->id, %data)); |
---|
[83] | 353 | } else { |
---|
[197] | 354 | # No error, but creation is denied |
---|
| 355 | return 'Creation skipped'; |
---|
[83] | 356 | } |
---|
[105] | 357 | |
---|
| 358 | return; |
---|
[83] | 359 | } |
---|
| 360 | |
---|
[122] | 361 | =head2 search_objects($otype, %filter) |
---|
| 362 | |
---|
| 363 | Search object according %filter. %filter is a list |
---|
| 364 | of field/value which should match. |
---|
| 365 | |
---|
| 366 | A default function is provided but each db driver can provide |
---|
| 367 | an optimize version. |
---|
| 368 | |
---|
| 369 | =cut |
---|
| 370 | |
---|
| 371 | sub search_objects { |
---|
| 372 | my ($self, $otype, %filter) = @_; |
---|
| 373 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 374 | $pclass->search($self, %filter); |
---|
| 375 | } |
---|
| 376 | |
---|
[257] | 377 | sub attributes_summary { |
---|
| 378 | my ($self, $otype, $attr) = @_; |
---|
| 379 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 380 | $pclass->attributes_summary($self, $attr); |
---|
| 381 | } |
---|
| 382 | |
---|
[137] | 383 | sub find_next_numeric_id { |
---|
| 384 | my ($self, $otype, $field, $min, $max) = @_; |
---|
| 385 | my $pclass = $self->_load_obj_class($otype) or return; |
---|
| 386 | $pclass->find_next_numeric_id($self, $field, $min, $max); |
---|
| 387 | } |
---|
| 388 | |
---|
[231] | 389 | sub authenticate_user { |
---|
| 390 | my ($self, $username, $passwd) = @_; |
---|
| 391 | $username or return; |
---|
| 392 | my $uobj = $self->get_object('user', $username) or do { |
---|
| 393 | la_log(LA_ERR, "Cannot authenticate non existing user $username"); |
---|
| 394 | return; |
---|
| 395 | }; |
---|
| 396 | my $password = $uobj->get_c_field('userPassword') or do { |
---|
| 397 | la_log(LA_ERR, "Cannot authenticate user $username having no passwd"); |
---|
| 398 | return; |
---|
| 399 | }; |
---|
| 400 | if ($password eq crypt($passwd, $password)) { # crypt unix |
---|
| 401 | return 1; |
---|
| 402 | } else { |
---|
| 403 | la_log(LA_ERR, "Cannot authenticate user $username"); |
---|
| 404 | return 0; |
---|
| 405 | } |
---|
| 406 | } |
---|
| 407 | |
---|
[3] | 408 | 1; |
---|
[2] | 409 | |
---|
[3] | 410 | __END__ |
---|
[2] | 411 | |
---|
[3] | 412 | =head1 SEE ALSO |
---|
[2] | 413 | |
---|
| 414 | =head1 AUTHOR |
---|
| 415 | |
---|
[17] | 416 | Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.fr<gt> |
---|
[2] | 417 | |
---|
| 418 | =head1 COPYRIGHT AND LICENSE |
---|
| 419 | |
---|
| 420 | Copyright (C) 2009 by Thauvin Olivier |
---|
| 421 | |
---|
| 422 | This library is free software; you can redistribute it and/or modify |
---|
| 423 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 424 | at your option, any later version of Perl 5 you may have available. |
---|
| 425 | |
---|
| 426 | =cut |
---|