#!/usr/local/bin/perl -w # Copyright 2006-2008 Tom Spindler and Yahoo! Inc. # This file is covered by perl's Artistic license. my $cvsid = <<'EOT'; $Id: vqpd,v 1.35 2008/05/20 08:56:32 dogcow Exp $ EOT use strict; use Config; use POSIX; use Socket; use Getopt::Std; use Sys::Syslog qw(:DEFAULT setlogsock); # setlogsock needed because syslog runs with -s. bleh. my (%opts, $debug, $vmpsdbfile, %var, %acl); getopts('sNvd:f:p:', \%opts); my ($versiondate) = join " ", (split /\s+/, $cvsid)[2,3]; if (1 != (scalar @ARGV + defined $opts{f})) { print STDERR<<"EOT"; vqpd version $versiondate vqpd usage: vqpd [-v|-d#] [-s] [-N] [-p port] (-f config | vmpsdbfile) For more info, type `perldoc $0` EOT exit 0; } =head1 vqpd - a vlan query protocol server (aka 'VMPS server') Z<> =head2 Invocation: vqpd B<[-v|-d F<#>] [-s] [-N] [-p port] (-f F | F)> -d F<#>: set debug level ('-v' == '-d 1') -s: don't syslog -N: don't fork =head2 Signals Reloads on HUP; dies on INT or TERM; increments debugging level on USR1, decrements on USR2. =cut $debug = defined $opts{v} ? 4 : 5; $debug = 5 - $opts{d} if defined $opts{d}; if (defined $opts{f}) { &readvqpconf; } else { $vmpsdbfile = shift @ARGV; } my @syslevels = qw(NONE debug info notice warning); setlogsock('unix'); openlog "vqpd", "pid", "user"; my (%destvlan, $fallbackvlan); &readvmpsdb; die "Uh oh. No entries?" if ! scalar keys %destvlan; my $vqpport = 1589; $vqpport = $opts{p} if defined $opts{p}; my $proto = getprotobyname('udp'); my $sock; socket($sock, PF_INET, SOCK_DGRAM, $proto) or die "Socket: $!"; setsockopt($sock, SOL_SOCKET, SO_REUSEADDR, pack("l",1)) or die "sso: $!"; bind($sock, sockaddr_in($vqpport, INADDR_ANY)) or die "bind: $!"; $opts{N} = 1 if length ref $DB::OUT; unless ($opts{N}) { fork && exit } debugout("vqpd started on port $vqpport\n", 3); $SIG{HUP} = \&readvmpsdb; $SIG{INT} = $SIG{TERM} = \&doshutdown; $SIG{USR1} = $SIG{USR2} = \&setverbosity; $SIG{CHLD} = 'IGNORE'; if (open Z, ">/var/run/vqpd.$vqpport") { print Z "$$\n"; close Z; } else { warn "Couldn't write to /var/run/vqpd.$vqpport!"; } my ($data, $who, $locpsn); REQUEST: while (1) { next unless ($who = recv $sock, $data, 65536, 0); # Why this construction rather than "while ($who = recv...)"? # In the brave new world of perl 5.8, signals are now "reliable" - # meaning that they don't restart interrupted system calls. # This means that if the recv() is interrupted by a signal, # the recv throws an error - which thus ends the loop. # By decoupling the loop construct from the recv, this is avoided. =head1 VQP - VLAN Query Protocol Z<> UDP, port 1589 all shorts (2 bytes) and longs (4 bytes) are in network byte order. =head2 packet sequence: protocol version, byte 0x01 (always) message type, byte 0x1: (initial) request 0x2: response to 0x0 request 0x3: reconfirmation request 0x4: response to 0x2 request error code, byte 0x00: no error 0x03: access denied (i.e. the router isn't allowed to request) also seems to be returned by catalysts when they're processing a config file and aren't ready yet. 0x04: port is shutdown 0x05: requested VTP domain is invalid (0x0 and 0x2 queries always use response code 0x0 - no error.) subpacket count, byte generally, packets w/ 0x0/0x2 messages => six subpackets; 0x1/0x3 => two. packet sequence #, long =cut my ($k, $reqtype, $response, $nitems, $psn) = unpack("CCCCN", (substr $data, 0, 8, '')); unless ($k == 1) { debugout("* Unknown packet ID!\n", 1); next; } my ($reqport, $reqip) = sockaddr_in($who); my $reqipdots = inet_ntoa($reqip); debugout("got psn $psn, query type $reqtype, $nitems subpkts\n", 0); unless ($reqtype & 0x1) { debugout("* Not a request packet!?\n", 1); next; } =pod =head2 subpacket sequence packet type, long (i.e. 0x0c01 is actually 0x00000c01) 0x0c01: requesting switch's IP (e.g. 0x0a090807) 0x0c02: host's port name (e.g. Fa0/2) 0x0c03: host's current VLAN (e.g. 'VLAN0100' or '--NONE--') also used to indicate VLANs in responses. 0x0c04: VTP domain (e.g. 'Bunny') 0x0c05: Ethernet packet (raw ether frame, MAC at offset 0x06) Sometimes sent instead of 0x0c06. 0x0c06: host's MAC (e.g. de:ad:be:ef:ca:fe) only sent in type 0x0 requests. 0x0c07: unknown (usually 0, but sometimes 1-7, or 0x0c (?) ) if I were to hazard a WAG, it's possibly the number of request retries for that particular MAC. 0x0c08: MAC sent in confirmation (e.g. 0x000102030405) sent in 0x1, 0x2, and 0x3 type requests. data length, short (# of bytes) data payload, bytes (strings are not null-terminated) The selection criteria for sending 0x0c05 vs 0x0c06 is a mystery to me. =head2 An example query and reply, as captured by Ethereal request: 01 01 00 06 request, no err, six spkts 00 00 6c ba psn (0x00006cba) 00 00 0c 01 00 04 c0 a8 01 2a IP address (192.168.1.42) 00 00 0c 02 00 05 46 61 30 2f 35 port name (Fa0/5) 00 00 0c 03 00 08 56 4c 41 4e 30 31 30 32 VLAN (VLAN0102) 00 00 0c 04 00 05 42 75 6e 6e 79 domain (Bunny 00 00 0c 07 00 01 00 NFI. attempt #, maybe? 00 00 0c 06 00 06 00 13 8f 16 e8 ab MAC (00:13:8f:16:e8:ab) response: 01 02 00 02 response to 0x0, no err, 2spkts 00 00 6c ba PSN (0x00006cba) 00 00 0c 03 00 08 56 4c 41 4e 30 31 30 32 VLAN (VLAN0102) 00 00 0c 08 00 06 de ad be ef ca fe MAC (de:ad:be:ef:ca:fe) =cut my ($macaddr, $packmac, $switchport, $switchip, $domain); for my $pkt (1 .. $nitems) { my ($type, $len) = unpack("Nn", (substr $data, 0, 6, '')); debugout(" Unknown subpacket!?", 1) if ($type & 0xffffff00) != 0x0c00; my $pdata = substr $data, 0, $len, ''; if ($type == 0x0c08 || $type == 0x0c06 || $type == 0x0c05) { debugout(" MAC spkt type: ", $type & 0xff, ";", 0); # all we really care about is the host's MAC. if ($type == 0x0c05) { substr $pdata, 0, 6, ''; # strip off the first six bytes of the ether dest; # the next six will be the requesting MAC, so fall through. } $packmac = substr $pdata, 0, 6, ''; # only grab the first six bytes, in case it's an ether frame. $macaddr = lc join ".", unpack("H4H4H4", $packmac); # debugout(" got macaddr $macaddr\n", 1); } elsif ($type == 0x0c07 and $debug) { my $n = ord($pdata); debugout("Oooh, got 0x0c07 and $n!\n", 2) if $n > 1; } elsif ($type == 0x0c02) { #the requesting switch $switchport = $pdata; } elsif ($type == 0x0c01) { #port the target host is on $switchip = join ".", unpack "C4", substr $pdata, 0, 4, ''; } elsif ($type == 0x0c04) { $domain = $pdata; } } debugout(" Huh. Extra data in packet?\n", 1) if length($data); if (!defined $macaddr) { debugout("Whoah - no MAC!?\n", 1); next; } # decide response - reply at all? provide a vlan? shut down the port? my $resp; if (defined $acl{nodomaindeny} && ! defined $domain) { # reject! # XXX 0x03 response, I guess. sendvqperr($sock, $psn, $reqtype, 3); debugout("refused domainless query from $switchip\n", 3); # XXX or should the reqIP be printed? next; } my $v; if (defined $destvlan{$macaddr}) { $v = $destvlan{$macaddr}; if (ref $v eq "HASH") { # dispatch according to location of requesting switch # (NOT the user switch itself, but the backplane or whatever.) $v = $v->{$reqipdots}; debugout("req was sent from $reqipdots\n", 2); } if (! defined $v) { # it's supposed to have an entry for the switch # in question, but doesn't. aiee! $v = $var{travelingvlan}[0]; debugout("= failed to find voice VLAN entry for $reqipdots!\n", 3); } } else { $v = $fallbackvlan; debugout("= unknown MAC $macaddr from $switchip $switchport !\n", 3); } # if a port is in a vmps-port-policies group (and are thus in # $acl{verboten}), then only ports explicitly listed are allowed to # use that VLAN. # thus, if keys %{$acl{1.2.3.4}{fa0/17}} == ('vlan0137', 'vlanwhee') # it's OK for vlan0137 or vlanwhee machines to be on that port. if (defined $acl{verboten}{$v}) { my $r = $acl{$switchip}; my $isok = 0; for my $p ('all', $switchport) { $r = $acl{$switchip}{$p} if 'HASH' eq ref $acl{$switchip}{$p}; $isok = 1 if (exists $r->{$v}); # has to be 'exists', not 'defined' } unless ($isok) { my $errcode = 3; # "access denied" $errcode = 4 if defined $acl{securemode}; # shutdown sendvqperr($sock, $psn, $reqtype, $errcode); debugout("rejected mac $macaddr on vlan $v for $switchip $switchport\n", 1); next REQUEST; } } # header: ID, response to request, no error, two subpkts, psn. $resp = pack "CCCCN", 1, 1 + $reqtype, 0, 2, $psn; # and subpackets: vlan assignment (0x0c03) and MAC response (0x0c08) $resp .= pack "Nna*", 0x0c03, length($v), $v; # vlan assignment $resp .= pack "Nna*", 0x0c08, 6, $packmac; # which MAC send $sock, $resp, 0, $who; debugout(" sent response for $macaddr via $reqipdots for $switchip $switchport: $v\n", 2); } sub doshutdown { debugout("Shutting down...\n", 3); shutdown($sock, 2); close $sock; unlink "/var/run/vqpd.$vqpport"; closelog; exit 0; } sub readvmpsdb { debugout("** Reading $vmpsdbfile... ", 3); unless (open Z, $vmpsdbfile) { debugout("Couldn't open $vmpsdbfile!", 4); die "Bailing out!" unless (scalar keys %destvlan); print "Keeping old config.\n"; return; } %destvlan=(); %acl=(); my ($group, %cfdata); my $mode = 'illegal'; # one spectacularly annoying thing about the VMPS db "specification" is # that it doesn't bother specifying a lot of things, and the logic to # "Which VLANs are allowed" and which ain't is a little bizarre. # yay cisco. # this also explains why the datastructures here are so contorted. :-| =pod =head2 VMPS config structure =head4 VLAN policies and a sample config fragment vmps-mac-addrs address dead.beef.cafe vlan-name roomA address ba1d.face.c01a vlan-name roomB vmps-port-group roomAports device 10.11.12.13 port Fa0/1 vmps-vlan-group roomAallowedVlans vlan-name roomA vmps-port-policies vlan-group roomAallowedVlans port-group roomAports When a VLAN group is listed in a C declaration, it means that the VLANs in that group may B appear on the ports designated. In our example config, hosts on the I VLAN would be allowed on I<10.11.12.13>, port I, and no others. Devices on I, on the other hand, may occur on any port (including I<10.11.12.13 Fa0/1>.) =cut while () { s/^\s+//; next if m/^[!#]/; study; if (m/^address\s+(\S+)\s+vlan-name\s+(\S+)$/i) { $destvlan{lc $1} = $2; } elsif (m/^vmps fallback (\S+)/i) { $fallbackvlan = $1; } elsif (m/^vmps\s+no-domain-req\s+deny/i) { $acl{nodomaindeny} = 1; } elsif (m/^vmps\s+mode\s+secure/i) { $acl{securemode} = 1; } elsif (m/^vmps-port-group\s+(\S+)/i) { $group = $1; $mode = "vpg"; } elsif (m/^vmps-vlan-group\s+(\S+)/i) { $group = $1; $mode = "vvg"; } elsif (m/^vmps-port-policies\s+vlan-group\s+(\S+)/i) { $group = $1; $mode = "vpp"; } elsif (m/^(port-group|vlan-name)\s+(\S+)/i) { $cfdata{$mode}{$group}{$1}{$2} = 1; } elsif (m/^(device)\s+(\S+)\s+port\s+(\S+)/i) { $cfdata{$mode}{$group}{$1}{$2}{$3} = 1; } elsif (m/^(device)\s+(\S+)\s+all-ports/i) { $cfdata{$mode}{$group}{$1}{$2}{'all'} = 1; } } close Z; debugout(scalar keys %destvlan, "unique MACs found.\n", 2); if (defined $cfdata{vvg} && defined $cfdata{vpp}) { # nested vlangroups -> flat vlangroups in $acl{}. my $vlang = &flattenhash($cfdata{vvg}, 'vlan-group', 'vlan-name'); # next, unnest vlanportgroups my $vlanpg = &flattenhash($cfdata{vpg}, 'port-group', 'device'); 1; # and now, deal with the actual vlan-port-policy stuff. my $p = $cfdata{vpp}; for my $portgrppol (keys %$p) { # for all portgroup policies... # is there actually a set of VLANs for this policy? my $vv = $vlang->{$portgrppol}; next unless ref $vv eq "HASH"; my @okvlans = keys %$vv; # yep, and here they are. my @stuff; # individual (i.e., non-portgroup) devices push @stuff, %{$p->{$portgrppol}{'device'}} if "HASH" eq ref $p->{$portgrppol}{'device'}; # portgroups, assuming they actually exist. for my $w (keys %{$p->{$portgrppol}{'port-group'}}) { push @stuff, %{$vlanpg->{$w}} if "HASH" eq ref $vlanpg->{$w}; } while (@stuff) { my $hash = pop @stuff; my $swip = pop @stuff; for my $port (keys %$hash) { @{$acl{$swip}{$port}}{@okvlans} = (); # !defined-but-exists } } for (@okvlans) { $acl{verboten}{$_} = 1; # "access-controlled" is probably more accurate, but eh. } } } # if exists(portgroup + vlangroup) 1; # process the stuff from %var involving the "vlan = DYNAMICVOIP" mapping for my $i (grep /^dynvoip/, keys %var) { my $v = $i; $v =~ s/dynvoip//; for my $j (@{$var{$i}}) { $destvlan{DYNAMICVOIP}{$j} = $v; } } } sub setverbosity { my ($sig) = @_; my $isindebugger = ref $DB::OUT; if ($sig eq "USR1") { $debug++; } elsif ($sig eq "USR2") { $debug = 0 if --$debug < 0; } print "Debug level now at $debug.\n"; } sub debugout { my $debuglvl = pop @_; my $out = join " ", @_; syslog($syslevels[$debuglvl], $out) unless !$debuglvl || defined $opts{'s'}; print $out unless $debug > $debuglvl; } sub readvqpconf { open Z, $opts{f} or die "Couldn't open " . $opts{f} . "!"; while () { s/;.*//; next if m/^\s*$/; if (m/^(\S+)\s*=\s*(\S+.*)/) { $var{$1} = [ split /\s+/, $2 ]; } } $vmpsdbfile = $var{vmpfilename}->[0]; die "No vmpsdb file defined!" if ! defined $vmpsdbfile; } sub sendvqperr { my ($s, $psn, $reqtype, $err) = @_; my $r = pack "CCCCN", 1, 1 + $reqtype, $err, 0, $psn; send $sock, $r, 0, $who; } sub flattenhash { # awooga, destructive to original hash! # but I don't wanna bother with Storable. my ($h, $nested, $leaf) = @_; my %flathash; =begin comment What this routine does: given a hash of the following form: group1 => { groups => { values }, leaves => { values } } group2 => { groups => { values }, leaves => { values } } flatten the tree to dereference all the groups into group1 => {leaves}, group2 => {leaves} so you can have group1 contain group2, which in turn contains group3, etc. This code is pretty simple-minded, so it doesn't look for cyclic graphs or anything of that sort. =end comment =cut die "&flattenhash wasn't passed a hash!" if "HASH" ne ref $h; my $flail = 1000000; # because I'm too lazy to refcount while (keys %$h && $flail--) { for my $k (keys %$h) { # if there are available flattened groups not yet undereferenced, # then flatten them. for my $group (keys %{$h->{$k}{$nested}}) { if (keys %{$flathash{$group}}) { # this monstrosity says for all foo in $flathash{$group}{foo}, # copy the entries as $h->{$k}{$leaf}{foo} @{$h->{$k}{$leaf}}{keys %{$flathash{$group}}} = values %{$flathash{$group}}; delete $h->{$k}{$nested}{$group}; } } # if there ain't any more nested bits to worry about.... if (!scalar keys %{$h->{$k}{$nested}}) { # copy to our 'real' hash, and delete the $cfdata one. $flathash{$k} = $h->{$k}{$leaf}; delete $h->{$k}; } } } return \%flathash; }