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

package LATMOS::Accounts::Bases::Sql::Nethost;

use 5.010000;
use strict;
use warnings;

use base qw(LATMOS::Accounts::Bases::Sql::objects);
use LATMOS::Accounts::Log;
use LATMOS::Accounts::I18N;
use Net::IP;

our $VERSION = (q$Rev: 2104 $ =~ /^Rev: (\d+) /)[0];

=head1 NAME

LATMOS::Accounts::Bases::Sql::Nethost - A Network Host entry

=cut

sub _object_table { 'nethost' }

sub _object_table_attributes_read { 'nethost_attributes_read' }

sub _key_field { 'name' }

sub _has_extended_attributes { 1 }

sub _get_attr_schema {
    my ($class, $base) = @_;

    $class->SUPER::_get_attr_schema($base,
        {
            name    => { ro => 1, inline => 1, },
            cn      => { ro => 1, inline => 1, iname => 'name' },
            date    => { ro => 1, inline => 1, },
            create  => { ro => 1, inline => 1, },
            expire    => {
                inline => 1,
                formtype => 'DATE',
                label => l('Expire'),
            },
            ip      => {
                monitored => 1,
                multiple => 1,
                uniq => 1,
                input => sub {
                    my $ip = $_[0] or return;
                    $ip =~ s/(\D|^)0+/$1/g;
                    $ip =~ s:/.*$::;
                    $ip
                },
                checkinputformat => sub {
                    my ($value) = @_;
                    $value or return;
                    my $ip = Net::IP->new($value);
                    $ip or return;
                    $ip->prefixlen() == ($ip->version == 4 ? 32 : 128) or do {
                        $base->log(LA_ERR, "Wrong prefix len for IP %s: %d (ip version %d)",
                            $ip->print, $ip->prefixlen, $ip->version);
                        return undef;
                    };
                },
                label => l('Ip'),
            },
            ipFrom  => {
                multiple => 1, 
                managed => 1,
                delayed => 1,
                can_values => sub {
                    $base->search_objects('netzone', 'type=dhcp')
                },
                set => sub {
                    my ($self, $data) = @_;
                    my $count = 0;
                    foreach (ref $data ? @{$data} : $data) {
                        my $zone = $self->base->get_object('netzone', $_)
                            or next;
                        my @freeips = $zone->get_attributes('freeIP') or next;
                        my $idx = rand(scalar(@freeips));
                        $self->object->_addAttributeValue('ip', $freeips[$idx]);
                        $self->base->log(LA_NOTICE, "Assigning ip %s to host %s",
                            $freeips[$idx], $self->object->id);
                        $count++;
                    }
                    return $count;
                },
                label => l('Ip from...'),
            },
            macaddr => {
                monitored => 1,
                multiple => 1,
                uniq => 1,
                input => sub {
                    $_[0] or return;
                    $_[0] =~ /^([0-9a-f]{2}([:-]|$)){6}$/i or return $_[0];
                    my @elem = split(/[:-]/, $_[0]);
                    return join(':', map { sprintf("%02x", hex($_)) || $_ } @elem);
                },
                checkinputformat => sub {
                    $_[0] or return;
                    return $_[0] =~ /^([0-9a-f]{2}([:-]|$)){6}$/i ? 1 : undef;
                },
                label => l('Hardware address'),
            },
            cname   => {
                monitored => 1,
                multiple => 1,
                input => sub { lc($_[0]) },
                label => l('Aliases'),
            },
            related   => {
                multiple => 1, uniq => 1,
                reference => 'nethost',
                label => l('Related'),
            },
            owner   => {
                monitored => 1,
                reference => 'user',
                delayed => 1,
                label => l('Owner'),
            },
            user    => {
                reference => 'user',
                delayed => 1,
                label => l('User'),
            },
            netZone => {
                multiple => 1, ro => 1, managed => 1,
                reference => 'netzone',
                label => l('NetZones'),
            },
            puppetClass => {
                multiple => 1,
                label => l('Puppet Class'),
            },
            netZoneExclude => {
                multiple => 1, ro => 1, managed => 1,
                reference => 'netzone',
                get => sub {
                    my ($self) = @_;
                    my $find = $self->base->db->prepare_cached(q{
                        select name from netzone where ikey in
                        (
                        select netzone_attributes.okey from netzone_attributes join
                        nethost_attributes_ips on netzone_attributes.attr='netExclude'
                            and 
                        nethost_attributes_ips.value::inet <<=
                        netzone_attributes.value::inet
                        where nethost_attributes_ips.okey = $1
                        )
                            order by name
                        });
                    $find->execute($self->object->get_attributes('ikey'));
                    my @zones;
                    while (my $res = $find->fetchrow_hashref) {
                        push(@zones, $res->{name});
                    }
                    return @zones ? [ @zones ] : undef;
                },
            },
            noDynamic => { 
                formtype => 'CHECKBOX',
                label => l('No dynamic IP'),
            },
            exported => { formtype => 'CHECKBOX', },
            noInheritPuppet => {
                formtype => 'CHECKBOX',
                label => l('No puppet'),
            },
            otherName => {
                multiple => 1,
                input => sub { lc($_[0]) },
                label => l('Other name'),
            },
            sshfp => {
                multiple => 1,
                label => l('SSH finger print'),
            },
            ip6 => { },
            sshfpUpdate  => {
                managed => 1,
                iname => 'sshfp',
                input => sub {
                    my ($self, $data) = @_;
                    $data or return;
                    open(my $h, '<', $data) or return;
                    my @sshfps;
                    while (my $line = <$h>) {
                        my ($type, $mode, $key) = $line =~ /^\S+\s+IN\s+SSHFP\s+(\d)\s+(\d)\s+(\S+)/i
                            or do {
                            la_log(LA_ERR, "Seems to not be a ssh-keygen line: %s", $line);
                            return;
                        };
                        la_log(LA_DEBUG, "found sshfp %s %s %s", $type, $mode, $key);
                        push(@sshfps, "$type $mode $key");
                    }
                    close($h);
                    \@sshfps;
                }
            },
            comment => {
                label => l('Comment'),
            },
            description => {
                label => l('Description'),
            },
            encryptKey => {
                label => l('Encrypted key'),
            },
            reverse => {
                label => l('Reverse name'),
            },
            serialNumber => {
                label => l('Serial number'),
            },
            inventoryNumber => {
                label => l('Inventory number'),
            },
        }
    )
}

sub set_fields {
    my ($self, %data) = @_;

    my $res = $self->SUPER::set_fields(%data);

    # Post update related
    if (exists $data{related}) {
        my %exists;
        if ($data{related}) {
            my @related = ref $data{related} ? @{$data{related}} : $data{related};
            foreach (@related) {
                my $obj = $self->base->get_object('nethost', $_) or next;
                $exists{$obj->id} = 1; 
                my @current = grep { $_ } $obj->get_attributes('related');
                grep { $_ eq $self->id } @current and next;
                $obj->set_c_fields('related' => [ $self->id, @current ]);

            }
        }
        foreach ($self->base->search_objects('nethost', 'related=' . $self->id)) {
            my $obj = $self->base->get_object('nethost', $_) or next;
            $exists{$_} and next;
            my @current = grep { $_ eq $self->id } $obj->get_attributes('related');
            $obj->set_c_fields('related' => [ @current ]);
        }
    }

    $res
}

1;

__END__

=head1 SEE ALSO

L<LATMOS::Accounts::Bases::Sql::Netzones>, L<LATMOS::Accounts::Bases::Sql>

=head1 AUTHOR

Olivier Thauvin, E<lt>olivier.thauvin@latmos.ipsl.frE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008, 2009, 2010, 2011, 2012 CNRS SA/CETP/LATMOS

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.


=cut