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 eq $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
  95   # Returns all addresses in use.  Does not filter with $block. ref:f197bdbaa1
  96
  97   my ($class, $block, $exclude) = @_;
  98   my $ip_field = $class->table_info->{'ip_field'}
  99     or return ();
 100   # if the service doesn't have an ip_field, then it has no IP addresses
 101   # in use, yes?
 102
 103   my %hash = ( $ip_field => { op => '!=', value => '' } );
 104   #$hash{'blocknum'} = $block->blocknum if $block;
 105   $hash{'svcnum'} = { op => '!=', value => $exclude->svcnum } if ref $exclude;
 106   map { my $na = $_->NetAddr; $na ? $na->addr : () }
 107     qsearch({
 108         table     => $class->table,
 109         hashref   => \%hash,
 110         extra_sql => " AND $ip_field != '0e0'",
 111     });
 112 }
 113
 114 sub _used_addresses_in_block {
 115   my ($class, $block) = @_;
 116
 117   croak "_used_addresses_in_block() requires an FS::addr_block parameter"
 118     unless ref $block && $block->isa('FS::addr_block');
 119
 120   my $ip_field = $class->table_info->{'ip_field'};
 121   if ( !$ip_field ) {
 122     carp "_used_addresses_in_block() skipped, no ip_field";
 123     return;
 124   }
 125
 126   my $block_na = $block->NetAddr;
 127
 128   my $octets;
 129   if ($block->ip_netmask >= 24) {
 130     $octets = 3;
 131   } elsif ($block->ip_netmask >= 16) {
 132     $octets = 2;
 133   } elsif ($block->ip_netmask >= 8) {
 134     $octets = 1;
 135   }
 136
 137   #  e.g.
 138   # SELECT ip_addr
 139   # FROM svc_broadband
 140   # WHERE ip_addr != ''
 141   #   AND ip_addr != '0e0'
 142   #   AND ip_addr LIKE '10.0.2.%';
 143   #
 144   # For /24, /16 and /8 this approach is fast, even when svc_broadband table
 145   # contains 650,000+ ip records.  For other allocations, this approach is
 146   # not speedy, but usable.
 147   #
 148   # Note: A use case like this would could greatly benefit from a qsearch()
 149   #       parameter to bypass FS::Record objects creation and just
 150   #       return hashrefs from DBI.  200,000 hashrefs are many seconds faster
 151   #       than 200,000 FS::Record objects
 152   my %qsearch = (
 153       table     => $class->table,
 154       select    => $ip_field,
 155       hashref   => { $ip_field => { op => '!=', value => '' }},
 156       extra_sql => " AND $ip_field != '0e0' ",
 157   );
 158   if ( $octets ) {
 159     my $block_str = join('.', (split(/\D/, $block_na->first))[0..$octets-1]);
 160     $qsearch{extra_sql} .= " AND $ip_field LIKE ".dbh->quote("${block_str}.%");
 161   }
 162
 163   if ( $block->ip_netmask % 8 ) {
 164     # Some addresses returned by qsearch may be outside the network block,
 165     # so each ip address is tested to be in the block before it's returned.
 166     return
 167       grep { $block_na->contains( NetAddr::IP->new( $_ ) ) }
 168       map { $_->$ip_field }
 169       qsearch( \%qsearch );
 170   }
 171
 172   return
 173     map { $_->$ip_field }
 174     qsearch( \%qsearch );
 175 }
 176
 177 sub _is_used {
 178   my ($class, $addr, $exclude) = @_;
 179   my $ip_field = $class->table_info->{'ip_field'}
 180     or return '';
 181
 182   my $svc = qsearchs($class->table, { $ip_field => $addr })
 183     or return '';
 184
 185   return '' if ( ref $exclude and $exclude->svcnum == $svc->svcnum );
 186
 187   my $cust_svc = $svc->cust_svc;
 188   if ( $cust_svc ) {
 189     my @label = $cust_svc->label;
 190     # "svc_foo 1234 (Service Desc)"
 191     # this should be enough to identify it without leaking customer
 192     # names across agents
 193     "$label[2] $label[3] ($label[0])";
 194   } else {
 195     join(' ', $class->table, $svc->svcnum, '(unlinked service)');
 196   }
 197 }
 198
 199 =item attached_router
 200
 201 Returns the L<FS::router> attached via this service (as opposed to the one
 202 this service is connected through), that is, a router whose "svcnum" field
 203 equals this service's primary key.
 204
 205 If the 'router_routernum' pseudo-field is set, returns that router instead.
 206
 207 =cut
 208
 209 sub attached_router {
 210   my $self = shift;
 211   if ( length($self->get('router_routernum') )) {
 212     return FS::router->by_key($self->router_routernum);
 213   } else {
 214     qsearchs('router', { 'svcnum' => $self->svcnum });
 215   }
 216 }
 217
 218 =item attached_block
 219
 220 Returns the address block (L<FS::addr_block>) assigned to the attached_router,
 221 if there is one.
 222
 223 If the 'router_blocknum' pseudo-field is set, returns that block instead.
 224
 225 =cut
 226
 227 sub attached_block {
 228   my $self = shift;
 229   if ( length($self->get('router_blocknum')) ) {
 230     return FS::addr_block->by_key($self->router_blocknum);
 231   } else {
 232     my $router = $self->attached_router or return '';
 233     my ($block) = $router->addr_block;
 234     return $block || '';
 235   }
 236 }
 237
 238 =item radius_check
 239
 240 Returns nothing.
 241
 242 =cut
 243
 244 sub radius_check { }
 245
 246 =item radius_reply
 247
 248 Returns RADIUS reply items that are relevant across all exports and
 249 necessary for the IP address configuration of the service.  Currently, that
 250 means "Framed-Route" if there's an attached router.
 251
 252 =cut
 253
 254 sub radius_reply {
 255   my $self = shift;
 256
 257   my %reply = ();
 258
 259   if ( my $block = $self->attached_block ) {
 260     # block routed over dynamic IP: "192.168.100.0/29 0.0.0.0 1"
 261     # or
 262     # block routed over fixed IP: "192.168.100.0/29 192.168.100.1 1"
 263     # (the "1" at the end is the route metric)
 264     $reply{'Framed-Route'} = $block->cidr . ' ' .
 265                              ($self->ip_addr || '0.0.0.0') . ' 1';
 266   }
 267
 268   $reply{'Motorola-Canopy-Gateway'} = $self->addr_block->ip_gateway
 269     if FS::Conf->new->exists('radius-canopy') && $self->addr_block;
 270
 271   %reply;
 272 }
 273
 274 sub replace_check {
 275   my ($new, $old) = @_;
 276   # this modifies $old, not $new, which is a slight abuse of replace_check,
 277   # but there's no way to ensure that replace_old gets called...
 278   #
 279   # ensure that router_routernum and router_blocknum are set to their
 280   # current values, so that exports remember the service's attached router
 281   # and block even after they've been replaced
 282   my $router = $old->attached_router;
 283   my $block = $old->attached_block;
 284   $old->set('router_routernum', $router ? $router->routernum : 0);
 285   $old->set('router_blocknum', $block ? $block->blocknum : 0);
 286   my $err_or_ref = $new->NEXT::replace_check($old) || '';
 287   # because NEXT::replace_check($old) ends up trying to AUTOLOAD replace_check
 288   # which is dumb, but easily worked around
 289   ref($err_or_ref) ? '' : $err_or_ref;
 290 }
 291
 292 =item addr_status
 293
 294 Returns the ping status record for this service's address, if there
 295 is one.
 296
 297 =cut
 298
 299 sub addr_status {
 300   my $self = shift;
 301   my $addr = $self->ip_addr or return;
 302   qsearchs('addr_status', { 'ip_addr'  => $addr });
 303 }
 304
 305 =item addr_status_color
 306
 307 Returns the CSS color for the ping status of this service.
 308
 309 =cut
 310
 311 # subject to change; should also show high/low latency (yellow?) and
 312 # staleness of data (probably means the daemon is not running) and packet
 313 # loss (once we measure that)
 314
 315 sub addr_status_color {
 316   my $self = shift;
 317   if ( my $addr_status = $self->addr_status ) {
 318     if ( $addr_status->up ) {
 319       return 'green';
 320     } else {
 321       return 'red';
 322     }
 323   } else {
 324     return 'gray';
 325   }
 326 }
 327
 328
 329 1;