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

Last change on this file was 2615, checked in by nanardon, 5 days ago

Fix upgrade
  • Property svn:keywords set to Id Rev
File size: 28.3 KB
Line 
1package LATMOS::Accounts::Bases::Sql;
2
3use 5.010000;
4use strict;
5use warnings;
6
7use base qw(LATMOS::Accounts::Bases);
8use LATMOS::Accounts::Log;
9use DBI;
10use Crypt::RSA;
11use Crypt::RSA::Key::Public::SSH;
12use Crypt::RSA::Key::Private::SSH;
13use Crypt::RSA::Key::Public;
14use Crypt::RSA::Key::Private;
15use Crypt::Blowfish;
16use MIME::Base64;
17
18our $VERSION = (q$Rev$ =~ /^Rev: (\d+) /)[0];
19
20sub SCHEMA_VERSION { 41 };
21
22=head1 NAME
23
24LATMOS::Ad - Perl extension for blah blah blah
25
26=head1 SYNOPSIS
27
28  use LATMOS::Accounts::Bases;
29  my $base = LATMOS::Accounts::Bases->new('unix');
30  ...
31
32=head1 DESCRIPTION
33
34Account base access over standard unix file format.
35
36=head1 FUNCTIONS
37
38=cut
39
40=head2 SCHEMA_VERSION
41
42Return the SQL schema version to use for this software version.
43
44=head2 new(%config)
45
46Create a new LATMOS::Ad object for windows AD $domain.
47
48domain / server: either the Ad domain or directly the server
49
50ldap_args is an optionnal list of arguments to pass to L<Net::LDAP>.
51
52=cut
53
54sub new {
55    my ($class, %config) = @_;
56   
57    my $base = {
58        db_conn => $config{db_conn},
59    };
60
61    bless($base, $class);
62}
63
64sub DESTROY {
65    my ($self) = @_;
66    $self->{_db} && $self->{_db}->rollback;
67}
68
69=head2 db
70
71Return a L<DBI> handle over database, load it if need.
72
73=cut
74
75sub db {
76    my ($self) = @_;
77
78    if ($self->{_db} && $self->{_db}->ping) {
79        return $self->{_db};
80    } else {
81        $self->{_db} = DBI->connect_cached(
82            'dbi:Pg:' . $self->{db_conn},
83            undef, undef,
84            {
85                RaiseError => 0,
86                AutoCommit => 0,
87                PrintWarn => 1,
88                PrintError => 1,
89            }
90        ) or do {
91            $self->log(LA_ERR, "Cannot connect to database: %s", $DBI::errstr);   
92            return;
93        };
94        $self->{_db}->do(q{set DATESTYLE to 'DMY'});
95        $self->log(LA_DEBUG, 'New connection to DB');
96
97        $self->get_global_value('sambaSID') or do {
98            $self->_setSambaSID;
99            $self->commit;
100        };
101
102        return $self->{_db};
103    }
104}
105
106sub IsSchemaUpToDate {
107    my ($self) = @_;
108
109    my $sv = $self->get_global_value('schema_version') || 1;
110    $self->log(LA_DEBUG, "DB is version $sv, code is " . SCHEMA_VERSION);
111
112    return $sv == SCHEMA_VERSION;
113}
114
115sub SchemaUpgrade {
116    my ($self) = @_;
117
118    if (!$self->IsSchemaUpToDate) {
119        require LATMOS::Accounts::Bases::Sql::upgrade;
120        if ($self->_SchemaUpgrade()) {
121            $self->commit;
122        } else {
123            $self->rollback;
124            return;
125        }
126    } else {
127        return 1;
128    }
129}
130
131=head2 load
132
133Read file and load data into memory
134
135=cut
136
137sub load {
138    my ($self) = @_;
139    if (!$self->db) { return 0 };
140
141    if (!$self->IsSchemaUpToDate) {
142        my $sv = $self->get_global_value('schema_version') || 1;
143        $self->log(LA_ERR, "Schema need update, please run `la-sql-upgrade -b %s'", $self->label); 
144        return;
145    }
146
147    if (!$self->_CreateInternalObjects) {
148        $self->rollback;
149    }
150
151    1;
152}
153
154sub _CreateInternalObjects {
155    my ($self) = @_;
156
157    my $dbi = $self->{_db};
158
159    my @objects = (
160        {
161            name => 'dpmt',
162            otype => 'sutype',
163            attrs => {
164                description => 'Department',
165            },
166        },
167        {
168            name => 'contrattype',
169            otype => 'sutype',
170            attrs => {
171                description => 'Contract',
172            },
173        },
174        {
175            name => '-useralias',
176            otype => 'group',
177            attrs => {
178                description => 'Internal group for user alias object',
179                gidnumber => -1,
180                unexported => 1,
181            },
182            intern => 1,
183        },
184    );
185
186    my $change = 0;
187
188    $self->temp_switch_unexported( sub {
189
190            my $setnodel  = $dbi->prepare('UPDATE objects SET nodelete     = true where name = ? and nodelete     = false');
191            my $setintern = $dbi->prepare('UPDATE objects SET internobject = true where name = ? and internobject = false');
192
193            foreach (@objects) {
194                if (!$self->GetRawObject($_->{otype}, $_->{name})) {
195                    printf("Creating object %s/%s\n", $_->{otype}, $_->{name});
196                    $self->create_object($_->{otype}, $_->{name}, %{$_->{attrs} || {}})
197                        or warn sprintf("cannot create %s/%s\n", $_->{otype}, $_->{name});
198            $change += 1;
199                }
200
201                $change +=  $setnodel->execute($_->{name});
202            $change +=  $setintern->execute($_->{name}) if ($_->{intern});
203            }
204
205    }, 1);
206
207    if ($change > 0) {
208        $self->db->commit;
209    }
210
211    return 1;
212}
213
214=head2 ListInternalObjects($otype)
215
216List objects flags as internal for type C<$otype>
217
218=cut
219
220sub ListInternalObjects {
221    my ($self, $otype) = @_;
222
223    my $pclass = $self->_load_obj_class($otype) or return;
224
225    # Object Alias: checking if object is alias, then returning it:
226    my $sth = $self->db->prepare_cached(
227        sprintf(q{select %s as k from %s where and internobject = true},
228            $self->db->quote_identifier($pclass->_key_field),
229            $self->db->quote_identifier($pclass->_object_table),
230        ),
231    );
232    $sth->execute();
233    my @list;
234    while (my $res = $sth->fetchrow_hashref) {
235       push(@list, $_->{k});
236   }
237   return(@list);
238}
239
240=head2 GetRawObject($otype, $id)
241
242Return an object even it is internal, alias are not follow and even
243unexported object are returned
244
245This function must be used only for maintenance operation.
246
247=cut
248
249sub GetRawObject {
250    my ($self, $otype, $id) = @_;
251
252    my $pclass = $self->_load_obj_class($otype) or return;
253
254    return $self->SUPER::get_object($otype, $id);
255}
256
257sub _derefObject {
258    my ($self, $otype, $oalias) = @_;
259    $oalias or return;
260    if (my ($aliasotype, $aliasoname, $aliasattr) = $oalias =~ m/^([^\/]+)\.([^\.]+)\.(.*)$/) {
261        my $attribute = $self->attribute($aliasotype, $aliasattr) or do {
262            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch attibute %s/%s",
263                $otype, $oalias, $aliasotype, $aliasattr);
264            return;
265        };
266        my $refotype = $attribute->reference or do {
267            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference an object",
268                $otype, $oalias);
269            return;
270        };
271        $refotype eq $otype or do {
272            $self->log(LA_DEBUG, "Oalias %s (%s): Attribute does not reference same object type",
273                $otype, $oalias, $refotype);
274            return;
275        };
276        my $robj = $self->get_object($aliasotype, $aliasoname) or do {
277            $self->log(LA_DEBUG, "Oalias %s (%s): can fetch object %s/%s",
278                $otype, $oalias, $aliasotype, $aliasoname);
279            return;
280        };
281        my $rvalue = $robj->get_attributes($aliasattr) or do {
282            $self->log(LA_DEBUG, "Oalias %s (%s): attribute value is empty",
283                $otype, $oalias);
284            return;
285        };
286        return $self->get_object($refotype, $rvalue);
287    } else {
288        return $self->get_object( $otype, $oalias )
289    }
290}
291
292sub get_object {
293    my ($self, $otype, $id) = @_;
294
295    my $pclass = $self->_load_obj_class($otype) or return;
296
297    # Object Alias: checking if object is alias, then returning it:
298    my $sth = $self->db->prepare_cached(
299        sprintf(q{select oalias from %s where %s = ? and internobject = false %s},
300            $self->db->quote_identifier($pclass->_object_table),
301            $self->db->quote_identifier($pclass->_key_field),
302            ($self->{wexported} ? '' : 'and exported = true'),
303        ),
304    );
305    $sth->execute($id);
306    my $res = $sth->fetchrow_hashref;
307    $sth->finish;
308    if (my $oalias = $res->{oalias}) {
309        # Cross reference over object/attribute
310        $self->_derefObject($otype, $oalias);
311    } else {
312        return $self->SUPER::get_object($otype, $id);
313    }
314}
315
316=head2 getObjectFromOKey ($okey)
317
318Return the object from the db internal key
319
320=cut
321
322sub getObjectFromOKey {
323    my ($self, $okey) = @_;
324
325    my $findobj = $self->{_db}->prepare_cached(q{
326        select * from objects_table where ikey = ?
327    });
328
329    $findobj->execute($okey);
330
331    my $res = $findobj->fetchrow_hashref;
332    $findobj->finish;
333
334    if ($res) {
335        return $self->get_object($res->{relname}, $res->{name});
336    } else {
337        return;
338    }
339}
340
341sub _sync_dyn_group {
342    my ($self) = @_;
343
344    my @groups = $self->search_objects('group', 'autoMemberFilter=*');
345
346    my $gres = 0;
347    foreach (@groups) {
348        my $g = $self->get_object('group', $_) or next;
349        my $res = $g->populate_dyn_group;
350        $self->log( LA_INFO, "Group Dyn $_ has been updated (res: $res)" ) if ($res);
351        $gres += $res
352    }
353
354    $self->log(LA_DEBUG, "Group Dyn res %d", $gres);
355    $gres
356}
357
358sub _sync_dyn_aliases {
359    my ($self) = @_;
360
361    my @aliases = $self->search_objects('aliases', 'autoMemberFilter=*');
362
363    my $gres = 0;
364    foreach (@aliases) {
365        my $g = $self->get_object('aliases', $_) or next;
366        my $res += $g->populate_dyn_aliases;
367        $self->log( LA_INFO, "Alias Dyn $_ has been updated (res: $res)" ) if ($res);
368        $gres += $res
369    }
370
371    $self->log(LA_DEBUG, "Aliases Dyn res %d", $gres);
372    $gres
373}
374
375=head2 PopulateDynData
376
377Recomputate dynamics attributes (autoMembersFilters) if need
378
379=cut
380
381sub PopulateDynData {
382    my ($self) = @_;
383
384    $self->log(LA_DEBUG, 'Running PopulateDynData()');
385
386    $self->temp_switch_unexported(sub {
387
388        foreach (1 .. 5) {
389            $self->log(LA_DEBUG, "%d loop for PopulateDynData", $_);
390            my $res = 0;
391            $res += $self->_sync_dyn_group   || 0;
392            $res += $self->_sync_dyn_aliases || 0;
393
394            if ($res == 0) {
395                last;
396            }
397        }
398
399        { # Trick for ssh keys
400            my %sshUser = map { $_ => 1 } (
401                $self->search_objects('user', 'authorizedKeys=*', 'oalias=NULL'),
402                $self->search_objects('user', 'sshPublicKeyFilter=*', 'oalias=NULL'),
403                $self->search_objects('user', 'sshPublicKey=*', 'oalias=NULL'),
404            );
405
406            foreach my $user (keys %sshUser) {
407                my $ouser = $self->get_object('user', $user) or next;
408                my $rawold = $ouser->_get_c_field('authorizedKeys');
409                my @old = sort grep { ! /^#/ } grep { defined $_ } ( ref $rawold ? @{ $rawold } : ( $rawold ) );
410                my $rawnew = $ouser->_get_c_field('_authorizedKeys');
411                my @new = sort grep { ! /^#/ } grep { defined $_ } ( ref $rawnew ? @{ $rawnew } : ( $rawnew ) );
412                if ( join( "\n", @old ) ne join( "\n", @new ) ) {
413                    $self->log(LA_INFO, "Updating authorizedKeys from filter for user $user" );
414                    $ouser->set_fields( 'authorizedKeys', $rawnew )
415                }
416            }
417        }
418
419    }, 0);
420
421    return 1;
422}
423
424sub _commit {
425    my ($self) = @_;
426
427    # Let sync-manager update data in background
428    $self->PopulateDynData unless($self->config('ASyncDynData'));
429
430    if ($ENV{LA_NO_COMMIT}) {
431        $self->log(LA_DEBUG, 'DB::COMMIT (ignore due to LA_NO_COMMIT)');
432        return 1;
433    } else {
434        $self->log(LA_DEBUG, 'DB::COMMIT');
435    }
436    $self->{__cache} = undef;
437    $self->db->commit;
438}
439
440sub _rollback {
441    my ($self) = @_;
442    if ($ENV{LA_NO_COMMIT}) {
443        $self->log(LA_DEBUG, 'DB::ROLLBACK (ignore due to LA_NO_COMMIT)');
444        return 1
445    } else {
446        $self->log(LA_DEBUG, 'DB::ROLLBACK');
447    }
448    $self->{__cache} = undef;
449    $self->db->rollback;
450}
451
452sub list_supported_objects {
453    my ($self, @otype) = @_;
454    $self->SUPER::list_supported_objects(qw(site), @otype);
455}
456
457# For SQL listRealObjects != list_objects
458sub listRealObjects {
459    my ($self, $otype) = @_;
460    my $pclass = $self->_load_obj_class($otype) or return;
461    $pclass->listReal($self);
462}
463
464sub key_field {
465    my ( $self, $otype ) = @_;
466
467    my $pclass = $self->_load_obj_class($otype) or return;
468    return $pclass->_key_field;
469}
470
471sub current_rev {
472    my ($self) = @_;
473    my $sth = $self->db->prepare_cached(
474        q{select max(rev) from revisions}
475    );
476    $sth->execute;
477    my $res = $sth->fetchrow_hashref;
478    $sth->finish;
479    return ($res->{max});
480} 
481
482sub authenticate_user {
483    my ($self, $username, $passwd) = @_;
484    $username or return;
485    my $uobj = $self->get_object('user', $username) or do {
486        la_log(LA_ERR, "Cannot authenticate non existing SQL user $username");
487        return;
488    };
489
490    if ($self->attribute('user', 'exported')) {
491        if (!$uobj->_get_c_field('exported')) {
492            la_log(LA_ERR, "User $username found but currently unexported");
493            return;
494        }
495    }
496
497    $self->SUPER::authenticate_user($username, $passwd);
498}
499
500=head1 SPECIFICS FUNCTIONS
501
502=head2 GetAlias($base, $id)
503
504Return object having id C<$id> only if it is an object alias
505
506=cut
507
508sub GetAlias {
509    my ($self, $otype, $id) = @_;
510
511    my $pclass = $self->_load_obj_class($otype) or return;
512
513    # Object Alias: checking if object is alias, then returning it:
514    my $sth = $self->db->prepare_cached(
515        sprintf(q{select oalias from %s where %s = ? and oalias IS NOT NULL and internobject = false %s},
516            $self->db->quote_identifier($pclass->_object_table),
517            $self->db->quote_identifier($pclass->_key_field),
518            ($self->{wexported} ? '' : 'and exported = true'),
519        ),
520    );
521    $sth->execute($id);
522    my $res = $sth->fetchrow_hashref;
523    $sth->finish;
524    if ($res) {
525        return $self->SUPER::get_object($otype, $id);
526    } else {
527        return;
528    }
529}
530
531=head2 CreateAlias($otype, $name, $for)
532
533Create an object alias named C<$name> for ovbject C<$for>
534
535=cut
536
537sub CreateAlias {
538    my ($self, $otype, $name, $for) = @_;
539
540    my $pclass = $self->_load_obj_class($otype) or return;
541
542    $for or die "Cannot create alias without giving object to point";
543
544    my $res = $pclass->CreateAlias($self, $name, $for);
545
546    if ($res) {
547        $self->ReportChange(
548            $otype,
549            $name,
550            $pclass->_get_ikey($self, $name),
551            'Create', "Alias %s %s => %s", $otype, $name, $for
552        );
553        $self->log(LA_DEBUG, "Alias $otype $name => $for created");
554        my $oalias = $self->GetAlias($otype, $name);
555        $oalias->_update_aliases_ptr();
556        return 1;
557    } else {
558        $self->log(LA_ERR, "Error when creating alias $otype $name");
559        return;
560    }
561}
562
563=head2 RenameAlias($otype, $name, $to)
564
565Rename an object alias
566
567=cut
568
569sub RenameAlias {
570    my ($self, $otype, $name, $to) = @_;
571
572    my $pclass = $self->_load_obj_class($otype) or return;
573
574    my $obj = $self->GetAlias($otype, $name) or do {
575        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
576        return;
577    };
578
579    my $sth = $self->db->prepare_cached(sprintf(
580        'UPDATE %s SET %s = ? WHERE %s = ?',
581        $self->db->quote_identifier($pclass->_key_field),
582        $self->db->quote_identifier($pclass->_object_table),
583        $self->db->quote_identifier($pclass->_key_field),
584    ));
585
586    my $res = $sth->execute($to, $name);
587
588    return $res;
589}
590
591=head2 RemoveAlias($otype, $name, $for)
592
593Create an object alias named C<$name> for ovbject C<$for>
594
595=cut
596
597sub RemoveAlias {
598    my ($self, $otype, $name) = @_;
599
600    my $pclass = $self->_load_obj_class($otype) or return;
601
602    my $obj = $self->GetAlias($otype, $name) or do {
603        $self->log('Cannot get alias %s/%s for removal', $otype, $name);
604        return;
605    };
606
607    if ($obj->_get_attributes('internobject')) {
608        # Cannot happend: internal are not fetchable
609        $self->log(LA_ERR,'Cannot delete %s/%s: is an internal object', $pclass->type, $name);
610        return;
611    }
612    if ($obj->_get_attributes('nodelete')) {
613        $self->log(LA_ERR,'Cannot delete %s/%s: is write protected', $pclass->type, $name);
614        return;
615    }
616
617    my $id = $obj->Iid;
618
619    my $sth = $self->db->prepare_cached(sprintf(
620        'DELETE FROM %s WHERE %s = ?',
621        $self->db->quote_identifier($pclass->_object_table),
622        $self->db->quote_identifier($pclass->_key_field),
623    ));
624
625    $obj->_update_aliases_ptr;
626    my $res = $sth->execute($name);
627
628    if ($res) {
629        $self->ReportChange(
630            $otype,
631            $name,
632            $id,
633            'Delete', "Alias %s %s deleted", $otype, $name
634        );
635        $self->log(LA_DEBUG, "Alias $otype $name removed");
636        return 1;
637    } else {
638        $self->log(LA_ERR, "Error when removing alias $otype $name");
639        return;
640    }
641}
642
643=head2 get_global_value ($varname)
644
645Return global value set into base
646
647=cut
648
649sub get_global_value {
650    my ($self, $varname) = @_;
651
652    my $sth = $self->db->prepare_cached(q{
653        select val from settings where varname = ?
654        });
655    $sth->execute($varname);
656    my $res = $sth->fetchrow_hashref;
657    $sth->finish;
658    $res->{val}
659}
660
661=head2 set_global_value ($varname, $value)
662
663Set global value.
664
665=cut
666
667sub set_global_value {
668    my ($self, $varname, $value) = @_;
669    my $sth = $self->db->prepare(q{
670        update settings set val = ? where varname = ?
671        });
672    $sth->execute($value, $varname) == 0 and do {
673        my $sth2 = $self->db->prepare(q{
674            insert into settings (val, varname) values (?,?)
675            });
676        $sth2->execute($value, $varname);
677    };
678}
679
680=head2 del_global_value ($varname)
681
682Delete global value from base
683
684=cut
685
686sub del_global_value {
687    my ($self, $varname) = @_;
688
689    my $sth = $self->db->prepare_cached(q{
690        delete from settings where varname = ?
691        });
692    return $sth->execute($varname);
693}
694
695=head2 generate_rsa_key ($password)
696
697Return public and private peer rsa keys
698
699=cut
700
701sub generate_rsa_key {
702    my ($self, $password) = @_;
703
704    my $rsa = new Crypt::RSA ES => 'PKCS1v15';
705    my ($public, $private) = $rsa->keygen (
706        Identity  => 'LATMOS-Accounts',
707        Size      => 2048,
708        Password  => $password,
709        Verbosity => 0,
710    ) or die $rsa->errstr(); # TODO avoid die
711    return ($public, $private);
712}
713
714=head2 private_key ($password)
715
716Load and return private rsa key
717
718=cut
719
720sub private_key {
721    my ($self, $password) = @_;
722    my $base = $self;
723    my $serialize = $base->get_global_value('rsa_private_key') or return;
724    my $string = decode_base64($serialize);
725    my $privkey = $string =~ /^SSH PRIVATE KEY FILE/
726        ? Crypt::RSA::Key::Private::SSH->new
727        : Crypt::RSA::Key::Private->new;
728    $privkey = $privkey->deserialize(
729        String => [ $string ],
730        Password => $password
731    );
732    $privkey->reveal( Password => $password );
733    $privkey;
734}
735
736=head2 get_rsa_password
737
738Return hash with peer username => encryptedPassword
739
740=cut
741
742sub get_rsa_password {
743    my ($self) = @_;
744    my $base = $self;
745    my $sth = $base->db->prepare(q{
746        select "name", value from "user" join user_attributes_base
747        on "user".ikey = user_attributes_base.okey
748        where user_attributes_base.attr = 'encryptedPassword'
749    });
750    $sth->execute;
751    my %users;
752    while (my $res = $sth->fetchrow_hashref) {
753        $users{$res->{name}} = $res->{value};
754    }
755    %users
756}
757
758=head2 store_rsa_key ($public, $private)
759
760Store public and private RSA key info data base
761
762=cut
763
764sub store_rsa_key {
765    my ($self, $public, $private) = @_;
766    my $base = $self;
767    $private->hide;
768    $base->set_global_value('rsa_private_key',
769        encode_base64($private->serialize));
770    $base->set_global_value('rsa_public_key',
771        $public->serialize);
772    return;
773}
774
775=head2 find_next_expire_users ($expire)
776
777Search user expiring in C<$expire> delay
778
779=cut
780
781sub find_next_expire_users {
782    my ($self, $expire) = @_;
783
784    my $sth= $self->db->prepare(q{
785        select name from "user" where
786            expire < now() + ?::interval
787            and expire > now()
788            and expire is not null
789            and internobject = false
790            } . ($self->{wexported} ? '' : 'and exported = true') . q{
791            order by expire
792        }
793    );
794    $sth->execute($expire || '1 month');
795    my @users;
796    while (my $res = $sth->fetchrow_hashref) {
797        push(@users, $res->{name});
798    }
799    @users
800}
801
802=head2 sambaSID($id)
803
804Return the base samba SID set in the config or a default one if none is set.
805
806If C<$id> is given return the full SID suitable for an object.
807
808=cut
809
810sub sambaSID {
811    my ($self, $id) = @_;
812
813    my $ssid = $self->get_global_value('sambaSID');
814    if (defined($id)) {
815        $ssid .= '-' . $id;
816    }
817    return $ssid;
818}
819
820sub _setSambaSID {
821    my ( $self ) = @_;
822
823    my $sid = sprintf(
824        'S-1-5-21-%d-%d',
825        int(rand 1000000000),
826        int(rand 1000000000),
827    );
828
829    $self->set_global_value( 'sambaSID', $sid );
830    return $sid;
831}
832
833
834
835=head2 find_expired_users ($expire)
836
837Return list of user going to expires in C<$expire> delay
838
839=cut
840
841sub find_expired_users {
842    my ($self, $expire) = @_;
843
844    my $sth= $self->db->prepare(q{
845        select name from "user" where
846            expire < now() - ?::interval
847            and expire is not null
848            and internobject = false
849        } . ($self->{wexported} ? '' : 'and exported = true') . q{
850            order by expire
851        }
852    );
853    $sth->execute($expire || '1 second');
854    my @users;
855    while (my $res = $sth->fetchrow_hashref) {
856        push(@users, $res->{name});
857    }
858    @users
859}
860
861=head2 rename_nethost ($nethostname, $to, %config)
862
863Facility function to rename computer to new name
864
865=cut
866
867sub rename_nethost {
868    my ($self, $nethostname, $to, %config) = @_;
869    {
870        my $obj = $self->get_object('nethost', $nethostname) or do {
871            $self->log(LA_ERR, 'Unable to rename non exisant host %s', $nethostname);
872            return;
873        };
874        $obj->_delAttributeValue(cname => $to);
875    }
876    $self->rename_object('nethost', $nethostname, $to) or return;
877    if ($config{'addcname'}) {
878        my $obj = $self->get_object('nethost', $to);
879        $obj->_addAttributeValue(cname => $nethostname);
880    }
881    return 1;
882}
883
884=head2 nethost_exchange_ip ($ip1, $ip2)
885
886Exchange ip1 with ip2 in base
887
888=cut
889
890sub nethost_exchange_ip {
891    my ($self, $ip1, $ip2) = @_;
892    my ($obj1, $obj2);
893    if (my ($host1) = $self->search_objects('nethost', "ip=$ip1")) {
894        $obj1 = $self->get_object('nethost', $host1);
895    } else {
896        $self->log(LA_ERR, "Cannot find host having $ip1");
897        return;
898    }
899    if (my ($host2) = $self->search_objects('nethost', "ip=$ip2")) {
900        $obj2 = $self->get_object('nethost', $host2);
901    } else {
902        $self->log(LA_ERR, "Cannot find host having $ip2");
903        return;
904    }
905    if ($obj1->id eq $obj2->id) {
906        $self->log(LA_ERR, "Both ip belong to same host (%s)", $obj1->id);
907        return;
908    }
909
910    $self->log(LA_NOTICE, "Exchanging IP between %s and %s", $obj1->id, $obj2->id);
911    $obj1->delAttributeValue('ip', $ip1) ;
912    $obj2->delAttributeValue('ip', $ip2) ;
913    $obj1->addAttributeValue('ip', $ip2) ;
914    $obj2->addAttributeValue('ip', $ip1) ;
915    return 1;
916}
917
918=head1 ATTRIBUTES FUNCTIONS
919
920=cut
921
922sub obj_attr_allowed_values {
923    my ($self, $otype, $attr) = @_;
924    if (my @values = $self->SUPER::obj_attr_allowed_values($otype, $attr)) {
925        return @values;
926    } else {
927        $self->ListAttrValue($otype, $attr);
928    }
929}
930
931=head2 ListAttrValue($otype, $attribute)
932
933List values allow for an attribute set into SQL database
934
935=cut
936
937sub ListAttrValue {
938    my ($self, $otype, $attr) = @_;
939
940    my @sqlvalues;
941    my $getAllow = $self->db->prepare_cached(q{
942        SELECT * FROM attributes_values WHERE otype = ? AND attributes = ?
943        ORDER BY "value"
944    });
945    $getAllow->execute($otype, $attr);
946    while (my $res = $getAllow->fetchrow_hashref) {
947        push(@sqlvalues, $res->{value});
948    }
949    return @sqlvalues;
950}
951
952=head2 AddAttrValue($otype, $attr, @values)
953
954Add given values to allowed attribute list
955
956=cut
957
958sub AddAttrValue {
959    my ($self, $otype, $attr, @values) = @_;
960   
961    my $addAllow = $self->db->prepare_cached(q{
962        INSERT INTO attributes_values (otype, attributes, "value") values (?,?,?)
963    });
964   
965    foreach my $value (@values) {
966        if ($addAllow->execute($otype, $attr, $value)) {
967        } else {
968            $self->rollback;
969            return;
970        }
971    }
972
973    return 1;
974}
975
976=head2 DelAttrValue
977
978Delete a
979
980=cut
981
982sub DelAttrValue {
983    my ($self, $otype, $attr, @values) = @_;
984
985    if (@values) {
986        my $delAllow = $self->db->prepare_cached(q{
987            DELETE FROM attributes_values WHERE otype = ? and attributes = ? and "value" = ?
988        });
989
990        foreach my $value (@values) {
991
992            if ($delAllow->execute($otype, $attr, $value)) {
993            } else {
994                $self->rollback;
995                return;
996            }
997
998        }
999        return 1;
1000    } else {
1001        my $delAllow = $self->db->prepare_cached(q{
1002            DELETE FROM attributes_values WHERE otype = ? and attributes = ?
1003        });
1004        if ($delAllow->execute($otype, $attr)) {
1005            return 1;
1006        } else {
1007            $self->rollback;
1008            return;
1009        }
1010    }
1011}
1012
1013=head2 getEmploymentRange
1014
1015Return date range within employment can be found in database
1016
1017=cut
1018
1019sub getEmploymentRange {
1020    my ($self, @filters) = @_;
1021
1022    my ($min,$max);
1023
1024    if (@filters) {
1025        my @flist = $self->search_objects('employment', @filters);
1026        my $minSql = $self->db->prepare(q{
1027            SELECT min(firstday) as min FROM employment
1028            WHERE name = ANY (?)
1029        });
1030        $minSql->execute(\@flist);
1031        if (my $res = $minSql->fetchrow_hashref) {
1032            $min = $res->{min}
1033        }
1034        my $maxSql = $self->db->prepare(q{
1035            SELECT max(lastday) as max FROM employment
1036            WHERE name = ANY (?)
1037        });
1038        $maxSql->execute(\@flist);
1039        if (my $res = $maxSql->fetchrow_hashref) {
1040            $max = $res->{max}
1041        }
1042    } else {
1043        my $minSql = $self->db->prepare(q{
1044            SELECT min(firstday) as min FROM employment
1045        });
1046        $minSql->execute;
1047        if (my $res = $minSql->fetchrow_hashref) {
1048            $min = $res->{min}
1049        }
1050        my $maxSql = $self->db->prepare(q{
1051            SELECT max(lastday) as max FROM employment
1052        });
1053        $maxSql->execute;
1054        if (my $res = $maxSql->fetchrow_hashref) {
1055            $max = $res->{max}
1056        }
1057    }
1058
1059    return ($min,$max);
1060}
1061
1062sub ReportChange {
1063    my ($self, $otype, $name, $ref, $changetype, $message, @args) = @_;
1064
1065    my $sthmodifiedby = $self->db->prepare(q{
1066        UPDATE objects set modifiedby = ? where ikey = ?
1067    });
1068
1069    $sthmodifiedby->execute(
1070        $self->LogUser,
1071        $ref,
1072    );
1073
1074    my ($potype, $pname, $pikey);
1075
1076    if (my $obj = $self->get_object($otype, $name)) {
1077        if (my $parent = $obj->ParentObject) {
1078            $potype = $parent->type;
1079            $pname  = $parent->id;
1080            $pikey  = $parent->Iid; 
1081        }
1082    }
1083
1084    my $sth = $self->db->prepare(q{
1085        INSERT into objectslogs (ikey, irev, otype, name, changetype, username, message, parentotype, parentname, parentikey)
1086        VALUES (?,?,?,?,?,?,?,?,?,?)
1087        });
1088
1089    $sth->execute(
1090        $ref,
1091        $self->current_rev,
1092        $otype,
1093        $name,
1094        $changetype,
1095        $self->LogUser,
1096        sprintf($message, @args),
1097        $potype, $pname, $pikey,
1098    );
1099}
1100
1101=head2 getobjectlogs($otype, @names)
1102
1103Return logs for object type C<$otype> having C<$name>.
1104
1105=cut 
1106
1107sub getobjectlogs {
1108    my ($self, $otype, @names) = @_;
1109
1110    my $sth = $self->db->prepare(q{
1111        select ikey from objectslogs where
1112            (otype = $1 and name  = $2)
1113        group by ikey
1114    });
1115    my @ids;
1116    foreach my $name (@names) {
1117        $sth->execute($otype, $name);
1118        while (my $res = $sth->fetchrow_hashref) {
1119            push(@ids, $res->{ikey});
1120        }
1121    }
1122    @ids or return;
1123
1124    my $sth2 = $self->db->prepare(
1125        q{
1126            select * from objectslogs where ikey = ANY ($1)
1127                or parentikey = ANY ($1)
1128            order by logdate asc
1129        },
1130    );
1131
1132    $sth2->execute( \@ids );
1133    my @logs;
1134    while (my $res = $sth2->fetchrow_hashref) {
1135        push(@logs, $res);
1136    }
1137
1138    return @logs;
1139}
1140
1141=head2 getlogs
1142
1143Return logs for last year
1144
1145=cut
1146
1147sub getlogs {
1148    my ($self) = @_;
1149    my $sth2 = $self->db->prepare(
1150        q{
1151            select * from objectslogs
1152            where logdate > now() - '1 year'::interval
1153            order by logdate asc
1154        },
1155    );
1156
1157    $sth2->execute();
1158    my @logs;
1159    while (my $res = $sth2->fetchrow_hashref) {
1160        push(@logs, $res);
1161    }
1162
1163    return @logs;
1164}
1165
11661;
1167
1168__END__
1169
1170=head1 SEE ALSO
1171
1172=head1 AUTHOR
1173
1174Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>
1175
1176=head1 COPYRIGHT AND LICENSE
1177
1178Copyright (C) 2008, 2009 CNRS SA/CETP/LATMOS
1179
1180This library is free software; you can redistribute it and/or modify
1181it under the same terms as Perl itself, either Perl version 5.10.0 or,
1182at your option, any later version of Perl 5 you may have available.
1183
1184
1185=cut
Note: See TracBrowser for help on using the repository browser.