FS/FS/svc_IP_Mixin.pm

   1 package FS::svc_IP_Mixin;
   2 use base 'FS::IP_Mixin';
   3
   4 use strict;
   5 use NEXT;
   6 use Carp qw(croak carp);
   7 use FS::Record qw(qsearchs qsearch dbh);
   8 use FS::Conf;
   9 use FS::router;
  10 use FS::part_svc_router;
  11
  12 =item addr_block
  13
  14 Returns the address block assigned to this service.
  15
  16 =item router
  17
  18 Returns the router assigned to this service, if there is one.
  19
  20 =cut
  21
  22 #addr_block and router methods provided by FS::IP_Mixin
  23
  24 =item NetAddr
  25
  26 Returns the address as a L<NetAddr::IP> object.  Use C<$svc->NetAddr->addr>
  27 to put it into canonical string form.
  28
  29 =cut
  30
  31 sub NetAddr {
  32   my $self = shift;
  33   NetAddr::IP->new($self->ip_addr);
  34 }
  35
  36 =item ip_addr
  37
  38 Wrapper for set/get on the IP address field.
  39
  40 =cut
  41
  42 sub ip_addr {
  43   my $self = shift;
  44   my $ip_field = $self->table_info->{'ip_field'}
  45     or return '';
  46   if ( @_ ) {
  47     $self->set($ip_field, @_);
  48   } else {
  49     $self->get($ip_field);
  50   }
  51 }
  52
  53 =item allowed_routers
  54
  55 Returns a list of L<FS::router> objects allowed on this service.
  56
  57 =cut
  58
  59 sub allowed_routers {
  60   my $self = shift;
  61   my $svcpart = $self->svcnum ? $self->cust_svc->svcpart : $self->svcpart;
  62   my @r = map { $_->router }
  63     qsearch('part_svc_router', { svcpart => $svcpart });
  64
  65   if ( $self->cust_main ) {
  66     my $agentnum = $self->cust_main->agentnum;
  67     return grep { !$_->agentnum or $_->agentnum == $agentnum } @r;
  68   } else {
  69     return @r;
  70   }
  71 }
  72
  73 =item svc_ip_check
  74
  75 Wrapper for C<ip_check> which also checks the validity of the router.
  76
  77 =cut
  78
  79 sub svc_ip_check {
  80   my $self = shift;
  81   my $error = $self->ip_check;
  82   return $error if $error;
  83   if ( my $router = $self->router ) {
  84     if ( grep { $_->routernum == $router->routernum } $self->allowed_routers ) {
  85       return '';
  86     } else {
  87       return 'Router '.$router->routername.' not available for this service';
  88     }
  89   }
  90   '';
  91 }
  92
  93 sub _used_addresses {
  94   my ($class, $block, $exclude_svc) = @_;
  95
  96   croak "_used_addresses() requires an FS::addr_block parameter"
  97     unless ref $block && $block->isa('FS::addr_block');
  98
  99   my $ip_field = $class->table_info->{'ip_field'};
 100   if ( !$ip_field ) {
 101     carp "_used_addresses() skipped, no ip_field";
 102     return;
 103   }
 104
 105   my %qsearch = ( $ip_field => { op => '!=', value => '' });
 106   $qsearch{svcnum} = { op => '!=', value => $exclude_svc->svcnum }
 107     if ref $exclude_svc && $exclude_svc->svcnum;
 108
 109   my $block_na = $block->NetAddr;
 110
 111   my $octets;
 112   if ($block->ip_netmask >= 24) {
 113     $octets = 3;
 114   } elsif ($block->ip_netmask >= 16) {
 115     $octets = 2;
 116   } elsif ($block->ip_netmask >= 8) {
 117     $octets = 1;
 118   }
 119
 120   #  e.g.
 121   # SELECT ip_addr
 122   # FROM svc_broadband
 123   # WHERE ip_addr != ''
 124   #   AND ip_addr != '0e0'
 125   #   AND ip_addr LIKE '10.0.2.%';
 126   #
 127   # For /24, /16 and /8 this approach is fast, even when svc_broadband table
 128   # contains 650,000+ ip records.  For other allocations, this approach is
 129   # not speedy, but usable.
 130   #
 131   # Note: A use case like this would could greatly benefit from a qsearch()
 132   #       parameter to bypass FS::Record objects creation and just
 133   #       return hashrefs from DBI.  200,000 hashrefs are many seconds faster
 134   #       than 200,000 FS::Record objects
 135   my %qsearch_param = (
 136       table     => $class->table,
 137       select    => $ip_field,
 138       hashref   => \%qsearch,
 139       extra_sql => " AND $ip_field != '0e0' ",
 140   );
 141   if ( $octets ) {
 142     my $block_str = join('.', (split(/\D/, $block_na->first))[0..$octets-1]);
 143     $qsearch_param{extra_sql}
 144       .= " AND $ip_field LIKE ".dbh->quote("${block_str}.%");
 145   }
 146
 147   if ( $block->ip_netmask % 8 ) {
 148     # Some addresses returned by qsearch may be outside the network block,
 149     # so each ip address is tested to be in the block before it's returned.
 150     return
 151       grep { $block_na->contains( NetAddr::IP->new( $_ ) ) }
 152       map { $_->$ip_field }
 153       qsearch( \%qsearch );
 154   }
 155
 156   return
 157     map { $_->$ip_field }
 158     qsearch( \%qsearch_param );
 159 }
 160
 161 sub _is_used {
 162   my ($class, $addr, $exclude) = @_;
 163   my $ip_field = $class->table_info->{'ip_field'}
 164     or return '';
 165
 166   my $svc = qsearchs($class->table, { $ip_field => $addr })
 167     or return '';
 168
 169   return '' if ( ref $exclude and $exclude->svcnum == $svc->svcnum );
 170
 171   my $cust_svc = $svc->cust_svc;
 172   if ( $cust_svc ) {
 173     my @label = $cust_svc->label;
 174     # "svc_foo 1234 (Service Desc)"
 175     # this should be enough to identify it without leaking customer
 176     # names across agents
 177     "$label[2] $label[3] ($label[0])";
 178   } else {
 179     join(' ', $class->table, $svc->svcnum, '(unlinked service)');
 180   }
 181 }
 182
 183 =item attached_router
 184
 185 Returns the L<FS::router> attached via this service (as opposed to the one
 186 this service is connected through), that is, a router whose "svcnum" field
 187 equals this service's primary key.
 188
 189 If the 'router_routernum' pseudo-field is set, returns that router instead.
 190
 191 =cut
 192
 193 sub attached_router {
 194   my $self = shift;
 195   if ( length($self->get('router_routernum') )) {
 196     return FS::router->by_key($self->router_routernum);
 197   } else {
 198     qsearchs('router', { 'svcnum' => $self->svcnum });
 199   }
 200 }
 201
 202 =item attached_block
 203
 204 Returns the address block (L<FS::addr_block>) assigned to the attached_router,
 205 if there is one.
 206
 207 If the 'router_blocknum' pseudo-field is set, returns that block instead.
 208
 209 =cut
 210
 211 sub attached_block {
 212   my $self = shift;
 213   if ( length($self->get('router_blocknum')) ) {
 214     return FS::addr_block->by_key($self->router_blocknum);
 215   } else {
 216     my $router = $self->attached_router or return '';
 217     my ($block) = $router->addr_block;
 218     return $block || '';
 219   }
 220 }
 221
 222 =item radius_check
 223
 224 Returns nothing.
 225
 226 =cut
 227
 228 sub radius_check { }
 229
 230 =item radius_reply
 231
 232 Returns RADIUS reply items that are relevant across all exports and
 233 necessary for the IP address configuration of the service.  Currently, that
 234 means "Framed-Route" if there's an attached router.
 235
 236 =cut
 237
 238 sub radius_reply {
 239   my $self = shift;
 240
 241   my %reply = ();
 242
 243   if ( my $block = $self->attached_block ) {
 244     # block routed over dynamic IP: "192.168.100.0/29 0.0.0.0 1"
 245     # or
 246     # block routed over fixed IP: "192.168.100.0/29 192.168.100.1 1"
 247     # (the "1" at the end is the route metric)
 248     $reply{'Framed-Route'} = $block->cidr . ' ' .
 249                              ($self->ip_addr || '0.0.0.0') . ' 1';
 250   }
 251
 252   $reply{'Motorola-Canopy-Gateway'} = $self->addr_block->ip_gateway
 253     if FS::Conf->new->exists('radius-canopy') && $self->addr_block;
 254
 255   %reply;
 256 }
 257
 258 sub replace_check {
 259   my ($new, $old) = @_;
 260   # this modifies $old, not $new, which is a slight abuse of replace_check,
 261   # but there's no way to ensure that replace_old gets called...
 262   #
 263   # ensure that router_routernum and router_blocknum are set to their
 264   # current values, so that exports remember the service's attached router
 265   # and block even after they've been replaced
 266   my $router = $old->attached_router;
 267   my $block = $old->attached_block;
 268   $old->set('router_routernum', $router ? $router->routernum : 0);
 269   $old->set('router_blocknum', $block ? $block->blocknum : 0);
 270   my $err_or_ref = $new->NEXT::replace_check($old) || '';
 271   # because NEXT::replace_check($old) ends up trying to AUTOLOAD replace_check
 272   # which is dumb, but easily worked around
 273   ref($err_or_ref) ? '' : $err_or_ref;
 274 }
 275
 276 =item addr_status
 277
 278 Returns the ping status record for this service's address, if there
 279 is one.
 280
 281 =cut
 282
 283 sub addr_status {
 284   my $self = shift;
 285   my $addr = $self->ip_addr or return;
 286   qsearchs('addr_status', { 'ip_addr'  => $addr });
 287 }
 288
 289 =item addr_status_color
 290
 291 Returns the CSS color for the ping status of this service.
 292
 293 =cut
 294
 295 # subject to change; should also show high/low latency (yellow?) and
 296 # staleness of data (probably means the daemon is not running) and packet
 297 # loss (once we measure that)
 298
 299 sub addr_status_color {
 300   my $self = shift;
 301   if ( my $addr_status = $self->addr_status ) {
 302     if ( $addr_status->up ) {
 303       return 'green';
 304     } else {
 305       return 'red';
 306     }
 307   } else {
 308     return 'gray';
 309   }
 310 }
 311
 312
 313 1;