Context Navigation

source: trunk/cgi-bin/IPDB.pm@ 732

Last change on this file since 732 was 732, checked in by Kris Deugau, 10 years ago

/trunk

Fill in next mergeBlocks() working segment: Merge to container, keep
suballocations, convert mergeable leaf blocks to free blocks. See #8.

Property svn:keywords set to Date Rev Author

File size: 99.8 KB

Line
1	# ipdb/cgi-bin/IPDB.pm
2	# Contains functions for IPDB - database access, subnet mangling, block allocation, etc
3	###
4	# SVN revision info
5	# $Date: 2015-05-22 15:44:39 +0000 (Fri, 22 May 2015) $
6	# SVN revision $Rev: 732 $
7	# Last update by $Author: kdeugau $
8	###
9	# Copyright (C) 2004-2010 - Kris Deugau
10
11	package IPDB;
12
13	use strict;
14	use warnings;
15	use Exporter;
16	use DBI;
17	use Net::SMTP;
18	use NetAddr::IP qw(:lower Compact );
19	use Frontier::Client;
20	use POSIX;
21	use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
22
23	$VERSION = 2; ##VERSION##
24	@ISA = qw(Exporter);
25	@EXPORT_OK = qw(
26	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
27	%IPDBacl %aclmsg %rpcacl $maxfcgi
28	$errstr
29	&initIPDBGlobals &connectDB &finish &checkDBSanity
30	&addMaster &touchMaster
31	&listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
32	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
33	&ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
34	&allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData
35	&getBlockRDNS &getRDNSbyIP
36	&getNodeList &getNodeName &getNodeInfo
37	&mailNotify
38	);
39
40	@EXPORT = (); # Export nothing by default.
41	%EXPORT_TAGS = ( ALL => [qw(
42	%disp_alloctypes %list_alloctypes %def_custids @citylist @poplist
43	%IPDBacl %aclmsg %rpcacl $maxfcgi
44	$errstr
45	&initIPDBGlobals &connectDB &finish &checkDBSanity
46	&addMaster &touchMaster
47	&listSummary &listSubs &listContainers &listAllocations &listForMerge &listFree &listPool
48	&getMasterList &getTypeList &getPoolSelect &findAllocateFrom
49	&ipParent &subParent &blockParent &getBreadCrumbs &getRoutedCity
50	&allocateBlock &updateBlock &splitBlock &shrinkBlock &mergeBlocks &deleteBlock &getBlockData
51	&getBlockRDNS &getRDNSbyIP
52	&getNodeList &getNodeName &getNodeInfo
53	&mailNotify
54	)]
55	);
56
57	##
58	## Global variables
59	##
60	our %disp_alloctypes;
61	our %list_alloctypes;
62	our %def_custids;
63	our @citylist;
64	our @poplist;
65	our %IPDBacl;
66
67	# Mapping hash for pooltype -> poolip-as-netblock conversions
68	my %poolmap = (sd => 'en', cd => 'cn', dp => 'cn', mp => 'cn', wp => 'cn', ld => 'in', ad => 'in', bd => 'in');
69
70	# mapping table for functional-area => error message
71	our %aclmsg = (
72	addmaster => 'add a master block',
73	addblock => 'add an allocation',
74	updateblock => 'update a block',
75	delblock => 'delete an allocation',
76	);
77
78	our %rpcacl;
79	our $maxfcgi = 3;
80
81	# error reporting
82	our $errstr = '';
83
84	our $org_name = 'Example Corp';
85	our $smtphost = 'smtp.example.com';
86	our $domain = 'example.com';
87	our $defcustid = '5554242';
88	our $smtpsender = 'ipdb@example.com';
89	# mostly for rwhois
90	##fixme: leave these blank by default?
91	our $rwhoisDataPath = '/usr/local/rwhoisd/etc/rwhoisd'; # to match ./configure defaults from rwhoisd-1.5.9.6
92	our $org_street = '123 4th Street';
93	our $org_city = 'Anytown';
94	our $org_prov_state = 'ON';
95	our $org_pocode = 'H0H 0H0';
96	our $org_country = 'CA';
97	our $org_phone = '000-555-1234';
98	our $org_techhandle = 'ISP-ARIN-HANDLE';
99	our $org_email = 'noc@example.com';
100	our $hostmaster = 'dns@example.com';
101
102	our $syslog_facility = 'local2';
103
104	our $rpc_url = '';
105	our $revgroup = 1; # should probably be configurable somewhere
106	our $rpccount = 0;
107
108	# Largest inverse CIDR mask length to show per-IP rDNS list
109	# (eg, NetAddr::IP->bits - NetAddr::IP->masklen)
110	our $maxrevlist = 5; # /27
111
112	# UI layout for subblocks/containers
113	our $sublistlayout = 1;
114
115	# VLAN validation mode. Set to 0 to allow alphanumeric vlan names instead of using the vlan number.
116	our $numeric_vlan = 1;
117
118
119	##
120	## Internal utility functions
121	##
122
123	## IPDB::_rpc
124	# Make an RPC call for DNS changes
125	sub _rpc {
126	return if !$rpc_url; # Just In Case
127	my $rpcsub = shift;
128	my %args = @_;
129
130	# Make an object to represent the XML-RPC server.
131	my $server = Frontier::Client->new(url => $rpc_url, debug => 0);
132	my $result;
133
134	my %rpcargs = (
135	rpcsystem => 'ipdb',
136	# must be provided by caller's caller
137	# rpcuser => $args{user},
138	%args,
139	);
140
141	eval {
142	$result = $server->call("dnsdb.$rpcsub", %rpcargs);
143	};
144	if ($@) {
145	$errstr = $@;
146	$errstr =~ s/\s*$//;
147	$errstr =~ s/Fault returned from XML RPC Server, fault code 4: error executing RPC `dnsdb.$rpcsub'\.\s//;
148	}
149	$rpccount++;
150
151	return $result if $result;
152	} # end _rpc()
153
154
155	## IPDB::_compactFree()
156	# Utility sub to compact a set of free block entries down to the minimum possible set of CIDR entries
157	# Not to be called outside of an eval{}!
158	sub _compactFree {
159	my $dbh = shift;
160	my $parent = shift;
161
162	# Rather than having the caller provide all the details
163	my $pinfo = getBlockData($dbh, $parent);
164	my $ftype = (split //, $pinfo->{type})[0];
165
166	# NetAddr::IP->compact() attempts to produce the smallest inclusive block
167	# from the caller and the passed terms.
168	# EG: if you call $cidr->compact($ip1,$ip2,$ip3) when $cidr, $ip1, $ip2,
169	# and $ip3 are consecutive /27's starting on .0 (.0-.31, .32-.63,
170	# .64-.95, and .96-.128), you will get an array containing a single
171	# /25 as element 0 (.0-.127). Order is not important; you could have
172	# $cidr=.32/27, $ip1=.96/27, $ip2=.0/27, and $ip3=.64/27.
173
174	##fixme: vrf
175	##fixme: simplify since all containers now represent different "layers"/"levels"?
176
177	# set up the query to get the list of blocks to try to merge.
178	my $sth = $dbh->prepare(q{
179	SELECT cidr,id FROM freeblocks
180	WHERE parent_id = ?
181	ORDER BY masklen(cidr) DESC
182	});
183	$sth->execute($parent);
184
185	my (@rawfb, @combinelist, %rawid);
186	my $i=0;
187	# for each free block under $parent, push a NetAddr::IP object into one list, and
188	# continuously use NetAddr::IP->compact to automagically merge netblocks as possible.
189	while (my ($fcidr, $fid) = $sth->fetchrow_array) {
190	my $testIP = new NetAddr::IP $fcidr;
191	push @rawfb, $testIP;
192	$rawid{"$testIP"} = $fid; # $data[0] vs "$testIP" does make a difference for v6
193	@combinelist = $testIP->compact(@combinelist);
194	}
195
196	# now that we have the full list of "compacted" freeblocks, go back over
197	# the list of raw freeblocks, and delete the ones that got merged.
198	$sth = $dbh->prepare("DELETE FROM freeblocks WHERE id = ?");
199	foreach my $rawfree (@rawfb) {
200	next if grep { $rawfree == $_ } @combinelist; # skip if the raw block is in the compacted list
201	$sth->execute($rawid{$rawfree});
202	}
203
204	# now we walk the new list of compacted blocks, and see which ones we need to insert
205	$sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
206	foreach my $cme (@combinelist) {
207	next if grep { $cme == $_ } @rawfb; # skip if the combined block was in the raw list
208	$sth->execute($cme, $pinfo->{city}, $ftype, $pinfo->{vrf}, $parent, $pinfo->{master_id});
209	}
210
211	} # end _compactFree()
212
213
214	## IPDB::_poolToAllocations
215	# Convert pool IPs into allocations, and free IPs into free blocks
216	# Takes a pool ID, original pool CIDR (in case the allocation has been updated before the call here)
217	# and hashref to data for the new parent container for the IPs,
218	# and an optional hash with the new parent ID and allocation type
219	sub _poolToAllocations {
220	my $dbh = shift;
221	my $oldpool = shift;
222	my $parentinfo = shift;
223	my %args = @_;
224
225	# Default to converting the pool to a container
226	$args{newparent} = $oldpool->{id} if !$args{newparent};
227
228	my ($containerclass) = ($parentinfo->{type} =~ /(.)./);
229
230	# Default type mapping
231	$args{newtype} = $poolmap{$oldpool->{type}} if !$args{newtype};
232
233	# Convert a bunch of pool IP allocations into "normal" netblock allocations
234	my $pool2alloc = $dbh->prepare(q{
235	INSERT INTO allocations (
236	cidr,type,city, description, notes, circuitid, createstamp, modifystamp,
237	privdata, custid, vrf, vlan, rdns, parent_id, master_id
238	)
239	SELECT
240	ip, ? AS type, city, description, notes, circuitid, createstamp, modifystamp,
241	privdata, custid, vrf, vlan, rdns, ? AS parent_id, master_id
242	FROM poolips
243	WHERE parent_id = ? AND available = 'n'
244	});
245	$pool2alloc->execute($args{newtype}, $args{newparent}, $oldpool->{id});
246
247	# Snag the whole list of pool IPs
248	my @freeips = @{$dbh->selectall_arrayref("SELECT ip,available FROM poolips WHERE parent_id = ?",
249	undef, $oldpool->{id})};
250	my @iplist;
251	my %usedips;
252	# Filter out the ones that were used...
253	foreach my $ip (@freeips) {
254	$$ip[0] =~ s{/32$}{};
255	push @iplist, NetAddr::IP->new($$ip[0]) if $$ip[1] eq 'y';
256	$usedips{$$ip[0]}++ if $$ip[1] eq 'n';
257	}
258	# ... so that we can properly decide whether the net, gw, and bcast IPs need to be added to the free list.
259	my $tmpblock = new NetAddr::IP $oldpool->{block};
260	push @iplist, NetAddr::IP->new($tmpblock->network->addr)
261	if !$usedips{$tmpblock->network->addr} \|\| $tmpblock->network->addr =~ /\.0$/;
262	push @iplist, NetAddr::IP->new($tmpblock->broadcast->addr)
263	if !$usedips{$tmpblock->broadcast->addr} \|\| $tmpblock->broadcast->addr =~ /\.255$/;
264	# only "DHCP"-ish pools have a gw ip removed from the pool
265	if ($oldpool->{type} =~ /.d/) {
266	$tmpblock++;
267	push @iplist, NetAddr::IP->new($tmpblock->addr);
268	}
269
270	# take the list of /32 IPs, and see what CIDR ranges we get back as free, then insert them.
271	@iplist = Compact(@iplist);
272	my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
273	foreach (@iplist) {
274	$insfbsth->execute($_, $parentinfo->{city}, $containerclass, $parentinfo->{vrf},
275	$args{newparent}, $parentinfo->{master_id});
276	}
277
278	# and finally delete the poolips entries
279	$dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, $oldpool->{id});
280
281	} # end _poolToAllocations()
282
283
284	## IPDB::_deleteCascade()
285	# Internal sub. Deletes an allocation and all subcomponents
286	sub _deleteCascade {
287	my $dbh = shift;
288	my $id = shift;
289	my $createfb = shift; # may be null at this point
290
291	my $binfo = getBlockData($dbh, $id);
292
293	# Decide if we're going to add a free block.
294
295	# Caller is normal block delete -> add freeblock under $binfo->{parent_id} -> pass nothing
296	# Caller is delete for merge to leaf -> do not add freeblock -> pass 0
297	# Caller is normal master delete -> do not add freeblock -> pass nothing
298	# Caller is merge master -> add freeblock under alternate parent -> pass parent ID
299	if ($binfo->{type} ne 'mm') {
300	# Deleting a non-master block
301	if (!defined($createfb)) {
302	# No createfb flag passed; assuming normal block delete. Add the freeblock
303	# under the parent of the block we're deleting.
304	$createfb = $binfo->{parent_id};
305	#} else {
306	# Don't need to actually do anything here. The caller has given us an ID,
307	# which is either 0 (causing no free block) or (theoretically) a valid block
308	# ID to add the free block under.
309	}
310	#} else {
311	# Deleting a master block
312	# Don't need to actually do anything here. If the caller passed a parent ID,
313	# that parent will get the new free block. if the caller didn't pass anything,
314	# no free block will be added.
315	}
316
317	##fixme: special-case master blocks up here and quickly delete based on master_id,
318	# instead of wasting time tracing parent relations
319
320	# grab all allocations in the master within the CIDR of the block to be deleted
321	my %parents;
322	my %cidrlist;
323	##fixme: limit by VRF?
324	my $sth = $dbh->prepare("SELECT cidr,id,parent_id FROM allocations WHERE cidr <<= ? AND master_id = ?");
325	$sth->execute($binfo->{block}, $binfo->{master_id});
326	while (my ($cidr, $cid, $pid) = $sth->fetchrow_array) {
327	$parents{$cid} = $pid;
328	$cidrlist{$cid} = $cidr;
329	}
330
331	# Trace the parent relations up the tree until we either hit parent ID 0 (we've found a master block
332	# but not the parent we're looking for - arguably this is already an error) or the parent ID matches
333	# the passed ID. If the latter, push the whole set into a second flag hash, so we can terminate
334	# further tree-tracing early.
335	my %found;
336	foreach my $cid (keys %parents) {
337	my @tmp;
338	if ($cid == $id) {
339	# "child" is the ID we've been asked to cascade-delete.
340	$found{$cid}++;
341	} elsif ($found{$cid}) {
342	# ID already seen and the chain terminates in our parent.
343	} elsif ($parents{$cid} == $id) {
344	# Immediate parent is the target parent
345	$found{$cid}++;
346	} else {
347	# Immediate parent isn't the one we're looking for. Walk the chain up until we hit our parent,
348	# the nonexistent parent id 0, or undefined (ID is not a child of the target ID at all)
349	# There are probably better ways to structure this loop.
350	while (1) {
351	# cache the ID
352	push @tmp, $cid;
353	# some very particularly defined loop ending conditions
354	if (!defined($parents{$cid}) \|\| $parents{$cid} == $id \|\| $parents{$cid} == 0) {
355	last;
356	} else {
357	# if we haven't found either the desired parent or another limiting condition,
358	# reset the ID to the parent next up the tree
359	$cid = $parents{$cid};
360	}
361	}
362	# if the current chain of relations ended with our target parent, shuffle the cached IDs into a flag hash
363	if (defined($parents{$cid}) && $parents{$cid} == $id) {
364	foreach (@tmp) { $found{$_}++; }
365	}
366	} # else
367	} # foreach my $cid
368
369	# Use the keys in the flag hash to determine which allocations to actually delete.
370	# Delete matching freeblocks and pool IPs; their parents are going away so we want
371	# to make sure we don't leave orphaned records lying around loose.
372	my @dellist = keys %found;
373	push @dellist, $id; # Just In Case the target ID didn't make the list earlier.
374	my $b = '?'. (',?' x $#dellist);
375	$dbh->do("DELETE FROM allocations WHERE id IN ($b)", undef, (@dellist) );
376	$dbh->do("DELETE FROM freeblocks WHERE parent_id IN ($b)", undef, (@dellist) );
377	$dbh->do("DELETE FROM poolips WHERE parent_id IN ($b)", undef, (@dellist) );
378
379	# Insert a new free block if needed
380	if ($createfb) {
381	my $pinfo = getBlockData($dbh, $createfb);
382	my $pt = (split //, $pinfo->{type})[1];
383	$dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
384	$binfo->{block}, $pinfo->{city}, $pt, $createfb, $pinfo->{vrf}, $binfo->{master_id});
385	}
386
387	##todo: and hey! bonus! we can return @dellist, or something (%cidrlist{@dellist})
388
389	} # end _deleteCascade()
390
391
392	##
393	## Public subs
394	##
395
396
397	## IPDB::initIPDBGlobals()
398	# Initialize all globals. Takes a database handle, returns a success or error code
399	sub initIPDBGlobals {
400	my $dbh = $_[0];
401	my $sth;
402
403	# Initialize alloctypes hashes
404	$sth = $dbh->prepare("select type,listname,dispname,listorder,def_custid from alloctypes order by listorder");
405	$sth->execute;
406	while (my @data = $sth->fetchrow_array) {
407	$disp_alloctypes{$data[0]} = $data[2];
408	$def_custids{$data[0]} = $data[4];
409	if ($data[3] < 900) {
410	$list_alloctypes{$data[0]} = $data[1];
411	}
412	}
413
414	# City and POP listings
415	$sth = $dbh->prepare("select city,routing from cities order by city");
416	$sth->execute;
417	return (undef,$sth->errstr) if $sth->err;
418	while (my @data = $sth->fetchrow_array) {
419	push @citylist, $data[0];
420	if ($data[1] eq 'y') {
421	push @poplist, $data[0];
422	}
423	}
424
425	# Load ACL data. Specific username checks are done at a different level.
426	$sth = $dbh->prepare("select username,acl from users");
427	$sth->execute;
428	return (undef,$sth->errstr) if $sth->err;
429	while (my @data = $sth->fetchrow_array) {
430	$IPDBacl{$data[0]} = $data[1];
431	}
432
433	##fixme: initialize HTML::Template env var for template path
434	# something like $self->path().'/templates' ?
435	# $ENV{HTML_TEMPLATE_ROOT} = 'foo/bar';
436
437	return (1,"OK");
438	} # end initIPDBGlobals
439
440
441	## IPDB::connectDB()
442	# Creates connection to IPDB.
443	# Requires the database name, username, and password.
444	# Returns a handle to the db.
445	# Set up for a PostgreSQL db; could be any transactional DBMS with the
446	# right changes.
447	sub connectDB {
448	my $dbname = shift;
449	my $user = shift;
450	my $pass = shift;
451	my $dbhost = shift;
452
453	my $dbh;
454	my $DSN = "DBI:Pg:".($dbhost ? "host=$dbhost;" : '')."dbname=$dbname";
455
456	# Note that we want to autocommit by default, and we will turn it off locally as necessary.
457	# We may not want to print gobbledygook errors; YMMV. Have to ponder that further.
458	$dbh = DBI->connect($DSN, $user, $pass, {
459	AutoCommit => 1,
460	PrintError => 0
461	})
462	or return (undef, $DBI::errstr) if(!$dbh);
463
464	# Return here if we can't select. Note that this indicates a
465	# problem executing the select.
466	my $sth = $dbh->prepare("select type from alloctypes");
467	$sth->execute();
468	return (undef,$DBI::errstr) if ($sth->err);
469
470	# See if the select returned anything (or null data). This should
471	# succeed if the select executed, but...
472	$sth->fetchrow();
473	return (undef,$DBI::errstr) if ($sth->err);
474
475	# If we get here, we should be OK.
476	return ($dbh,"DB connection OK");
477	} # end connectDB
478
479
480	## IPDB::finish()
481	# Cleans up after database handles and so on.
482	# Requires a database handle
483	sub finish {
484	my $dbh = $_[0];
485	$dbh->disconnect if $dbh;
486	} # end finish
487
488
489	## IPDB::checkDBSanity()
490	# Quick check to see if the db is responding. A full integrity
491	# check will have to be a separate tool to walk the IP allocation trees.
492	sub checkDBSanity {
493	my ($dbh) = $_[0];
494
495	if (!$dbh) {
496	print "No database handle, or connection has been closed.";
497	return -1;
498	} else {
499	# it connects, try a stmt.
500	my $sth = $dbh->prepare("select type from alloctypes");
501	my $err = $sth->execute();
502
503	if ($sth->fetchrow()) {
504	# all is well.
505	return 1;
506	} else {
507	print "Connected to the database, but could not execute test statement. ".$sth->errstr();
508	return -1;
509	}
510	}
511	# Clean up after ourselves.
512	# $dbh->disconnect;
513	} # end checkDBSanity
514
515
516	## IPDB::addMaster()
517	# Does all the magic necessary to sucessfully add a master block
518	# Requires database handle, block to add
519	# Returns failure code and error message or success code and "message"
520	sub addMaster {
521	my $dbh = shift;
522	# warning! during testing, this somehow generated a "Bad file descriptor" error. O_o
523	my $cidr = new NetAddr::IP shift;
524	my %args = @_;
525
526	$args{vrf} = '' if !$args{vrf};
527	$args{rdns} = '' if !$args{rdns};
528	$args{defloc} = '' if !$args{defloc};
529	$args{rwhois} = 'n' if !$args{rwhois}; # fail "safe", sort of.
530	$args{rwhois} = 'n' if $args{rwhois} ne 'n' and $args{rwhois} ne 'y';
531
532	my $mid;
533
534	# Allow transactions, and raise an exception on errors so we can catch it later.
535	# Use local to make sure these get "reset" properly on exiting this block
536	local $dbh->{AutoCommit} = 0;
537	local $dbh->{RaiseError} = 1;
538
539	# Wrap all the SQL in a transaction
540	eval {
541	# First check - does the master exist? Ignore VRFs until we can see a sane UI
542	my ($mcontained) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr >>= ? AND type = 'mm'",
543	undef, ($cidr) );
544	die "Master block $mcontained already exists and entirely contains $cidr\n"
545	if $mcontained;
546
547	# Second check - does the new master contain an existing one or ones?
548	my ($mexist) = $dbh->selectrow_array("SELECT cidr FROM allocations WHERE cidr <<= ? AND type = 'mm'",
549	undef, ($cidr) );
550
551	if (!$mexist) {
552	# First case - master is brand-spanking-new.
553	##fixme: rwhois should be globally-flagable somewhere, much like a number of other things
554	## maybe a db table called "config"?
555	$dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
556	($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
557	($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
558
559	# Unrouted blocks aren't associated with a city (yet). We don't rely on this
560	# elsewhere though; legacy data may have traps and pitfalls in it to break this.
561	# Thus the "routed" flag.
562	$dbh->do("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id) VALUES (?,?,?,?,?,?)", undef,
563	($cidr, '<NULL>', 'm', $mid, $args{vrf}, $mid) );
564
565	# master should be its own master, so deletes directly at the master level work
566	$dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
567
568	# If we get here, everything is happy. Commit changes.
569	$dbh->commit;
570
571	} # done new master does not contain existing master(s)
572	else {
573
574	# collect the master(s) we're going to absorb, and snag the longest netmask while we're at it.
575	my $smallmask = $cidr->masklen;
576	my $sth = $dbh->prepare("SELECT cidr,id FROM allocations WHERE cidr <<= ? AND type='mm' AND parent_id=0");
577	$sth->execute($cidr);
578	my @cmasters;
579	my @oldmids;
580	while (my @data = $sth->fetchrow_array) {
581	my $master = new NetAddr::IP $data[0];
582	push @cmasters, $master;
583	push @oldmids, $data[1];
584	$smallmask = $master->masklen if $master->masklen > $smallmask;
585	}
586
587	# split the new master, and keep only those blocks not part of an existing master
588	my @blocklist;
589	foreach my $seg ($cidr->split($smallmask)) {
590	my $contained = 0;
591	foreach my $master (@cmasters) {
592	$contained = 1 if $master->contains($seg);
593	}
594	push @blocklist, $seg if !$contained;
595	}
596
597	##fixme: master_id
598	# collect the unrouted free blocks within the new master
599	$sth = $dbh->prepare("SELECT cidr FROM freeblocks WHERE masklen(cidr) <= ? AND cidr <<= ? AND routed = 'm'");
600	$sth->execute($smallmask, $cidr);
601	while (my @data = $sth->fetchrow_array) {
602	my $freeblock = new NetAddr::IP $data[0];
603	push @blocklist, $freeblock;
604	}
605
606	# combine the set of free blocks we should have now.
607	@blocklist = Compact(@blocklist);
608
609	# master
610	$dbh->do("INSERT INTO allocations (cidr,type,swip,vrf,rdns) VALUES (?,?,?,?,?)", undef,
611	($cidr, 'mm', 'y', $args{vrf}, $args{rdns}) );
612	($mid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
613
614	# master should be its own master, so deletes directly at the master level work
615	$dbh->do("UPDATE allocations SET master_id = ? WHERE id = ?", undef, ($mid, $mid) );
616
617	# and now insert the new data. Make sure to delete old masters too.
618
619	# freeblocks
620	$sth = $dbh->prepare("DELETE FROM freeblocks WHERE cidr <<= ? AND parent_id IN (".join(',', @oldmids).")");
621	my $sth2 = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,parent_id,vrf,master_id)".
622	" VALUES (?,'<NULL>','m',?,?,?)");
623	foreach my $newblock (@blocklist) {
624	$sth->execute($newblock);
625	$sth2->execute($newblock, $mid, $args{vrf}, $mid);
626	}
627
628	# Update immediate allocations, and remove the old parents
629	$sth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
630	$sth2 = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
631	foreach my $old (@oldmids) {
632	$sth->execute($mid, $old);
633	$sth2->execute($old);
634	}
635
636	# whew If we got here, we likely suceeded.
637	$dbh->commit;
638
639	} # new master contained existing master(s)
640	}; # end eval
641
642	if ($@) {
643	my $msg = $@;
644	eval { $dbh->rollback; };
645	return ('FAIL',$msg);
646	} else {
647
648	# Only attempt rDNS if the IPDB side succeeded
649	if ($rpc_url) {
650
651	# Note not splitting reverse zones negates any benefit from caching the exported data.
652	# IPv6 address space is far too large to split usefully, and in any case (also due to
653	# the large address space) doesn't support the iterated template records v4 zones do
654	# that causes the bulk of the slowdown that needs the cache anyway.
655
656	my @zonelist;
657	# allow splitting reverse zones to be disabled, maybe, someday
658	#if ($splitrevzones && !$cidr->{isv6}) {
659	if (1 && !$cidr->{isv6}) {
660	my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
661	@zonelist = $cidr->split($splitpoint);
662	} else {
663	@zonelist = ($cidr);
664	}
665	my @fails;
666	##fixme: remove hardcoding where possible
667	foreach my $subzone (@zonelist) {
668	my %rpcargs = (
669	rpcuser => $args{user},
670	revzone => "$subzone",
671	revpatt => $args{rdns},
672	defloc => $args{defloc},
673	group => $revgroup, # not sure how these two could sanely be exposed, tbh...
674	state => 1, # could make them globally configurable maybe
675	);
676	if ($rpc_url && !_rpc('addRDNS', %rpcargs)) {
677	push @fails, ("$subzone" => $errstr);
678	}
679	}
680	if (@fails) {
681	$errstr = "Warning(s) adding $cidr to reverse DNS:\n".join("\n", @fails);
682	return ('WARN',$mid);
683	}
684	}
685	return ('OK',$mid);
686	}
687	} # end addMaster
688
689
690	## IPDB::touchMaster()
691	# Update last-changed timestamp on a master block.
692	sub touchMaster {
693	my $dbh = shift;
694	my $master = shift;
695
696	local $dbh->{AutoCommit} = 0;
697	local $dbh->{RaiseError} = 1;
698
699	eval {
700	$dbh->do("UPDATE allocations SET modifystamp=now() WHERE id = ?", undef, ($master));
701	$dbh->commit;
702	};
703
704	if ($@) {
705	my $msg = $@;
706	eval { $dbh->rollback; };
707	return ('FAIL',$msg);
708	}
709	return ('OK','OK');
710	} # end touchMaster()
711
712
713	## IPDB::listSummary()
714	# Get summary list of all master blocks
715	# Returns an arrayref to a list of hashrefs containing the master block, routed count,
716	# allocated count, free count, and largest free block masklength
717	sub listSummary {
718	my $dbh = shift;
719
720	my $mlist = $dbh->selectall_arrayref("SELECT cidr AS master,id,vrf FROM allocations ".
721	"WHERE type='mm' ORDER BY cidr",
722	{ Slice => {} });
723
724	foreach (@{$mlist}) {
725	my ($rcnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? AND type='rm' AND master_id = ?",
726	undef, ($$_{master}, $$_{id}));
727	$$_{routed} = $rcnt;
728	my ($acnt) = $dbh->selectrow_array("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
729	"AND NOT type='rm' AND NOT type='mm' AND master_id = ?",
730	undef, ($$_{master}, $$_{id}));
731	$$_{allocated} = $acnt;
732	my ($fcnt) = $dbh->selectrow_array("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?",
733	undef, ($$_{master}, $$_{id}));
734	$$_{free} = $fcnt;
735	my ($bigfree) = $dbh->selectrow_array("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
736	" AND master_id = ? ORDER BY masklen(cidr) LIMIT 1", undef, ($$_{master}, $$_{id}));
737	##fixme: should find a way to do this without having to HTMLize the <>
738	$bigfree = "/$bigfree" if $bigfree;
739	$bigfree = '<NONE>' if !$bigfree;
740	$$_{bigfree} = $bigfree;
741	}
742	return $mlist;
743	} # end listSummary()
744
745
746	## IPDB::listSubs()
747	# Get list of subnets within a specified CIDR block, on a specified VRF.
748	# Returns an arrayref to a list of hashrefs containing the CIDR block, customer location or
749	# city it's routed to, block type, SWIP status, and description
750	sub listSubs {
751	my $dbh = shift;
752	my %args = @_;
753
754	# Just In Case
755	$args{vrf} = '' if !$args{vrf};
756
757	# Snag the allocations for this block
758	my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
759	" FROM allocations WHERE parent_id = ? ORDER BY cidr");
760	$sth->execute($args{parent});
761
762	# hack hack hack
763	# set up to flag swip=y records if they don't actually have supporting data in the customers table
764	my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
765
766	# snag some more details
767	my $substh = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
768	"AND type ~ '[mc]\$' AND master_id = ? AND NOT cidr = ? ");
769	my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
770	"AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
771	my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
772	my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
773	" AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
774
775	my @blocklist;
776	while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
777	$desc .= " - vrf:$vrf" if $desc && $vrf;
778	$desc = "vrf:$vrf" if !$desc && $vrf;
779	$custsth->execute($custid);
780	my ($ncust) = $custsth->fetchrow_array();
781	$substh->execute($cidr, $mid, $cidr);
782	my ($cont) = $substh->fetchrow_array();
783	$alsth->execute($cidr, $mid, $id);
784	my ($alloc) = $alsth->fetchrow_array();
785	$freesth->execute($cidr, $mid);
786	my ($free) = $freesth->fetchrow_array();
787	$lfreesth->execute($cidr, $mid);
788	my ($lfree) = $lfreesth->fetchrow_array();
789	$lfree = "/$lfree" if $lfree;
790	$lfree = '<NONE>' if !$lfree;
791	my %row = (
792	block => $cidr,
793	subcontainers => $cont,
794	suballocs => $alloc,
795	subfree => $free,
796	lfree => $lfree,
797	city => $city,
798	type => $disp_alloctypes{$type},
799	custid => $custid,
800	swip => ($swip eq 'y' ? 'Yes' : 'No'),
801	partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
802	desc => $desc,
803	hassubs => ($type eq 'rm' \|\| $type =~ /.c/ ? 1 : 0),
804	id => $id,
805	);
806	# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
807	$row{listpool} = ($type =~ /^.[pd]$/);
808	push (@blocklist, \%row);
809	}
810	return \@blocklist;
811	} # end listSubs()
812
813
814	## IPDB::listContainers()
815	# List all container-type allocations in a given parent
816	# Takes a database handle and a hash:
817	# - parent is the ID of the parent block
818	# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
819	# description, block ID, and counts for the nmber uf suballocations (all types),
820	# free blocks, and the CIDR size of the largest free block
821	sub listContainers {
822	my $dbh = shift;
823	my %args = @_;
824
825	# Just In Case
826	$args{vrf} = '' if !$args{vrf};
827
828	# Snag the allocations for this block
829	my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
830	" FROM allocations WHERE parent_id = ? AND type ~ '[mc]\$' ORDER BY cidr");
831	$sth->execute($args{parent});
832
833	my $alsth = $dbh->prepare("SELECT count(*) FROM allocations WHERE cidr <<= ? ".
834	"AND NOT type='rm' AND NOT type='mm' AND master_id = ? AND NOT id = ?");
835	my $freesth = $dbh->prepare("SELECT count(*) FROM freeblocks WHERE cidr <<= ? AND master_id = ?");
836	my $lfreesth = $dbh->prepare("SELECT masklen(cidr) AS maskbits FROM freeblocks WHERE cidr <<= ?".
837	" AND master_id = ? ORDER BY masklen(cidr) LIMIT 1");
838
839	my @blocklist;
840	while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
841	$desc .= " - vrf:$vrf" if $desc && $vrf;
842	$desc = "vrf:$vrf" if !$desc && $vrf;
843	$alsth->execute($cidr, $mid, $id);
844	my ($alloc) = $alsth->fetchrow_array();
845	$freesth->execute($cidr, $mid);
846	my ($free) = $freesth->fetchrow_array();
847	$lfreesth->execute($cidr, $mid);
848	my ($lfree) = $lfreesth->fetchrow_array();
849	$lfree = "/$lfree" if $lfree;
850	$lfree = '<NONE>' if !$lfree;
851	my %row = (
852	block => $cidr,
853	suballocs => $alloc,
854	subfree => $free,
855	lfree => $lfree,
856	city => $city,
857	type => $disp_alloctypes{$type},
858	desc => $desc,
859	id => $id,
860	);
861	push (@blocklist, \%row);
862	}
863	return \@blocklist;
864	} # end listContainers()
865
866
867	## IPDB::listAllocations()
868	# List all end-use allocations in a given parent
869	# Takes a database handle and a hash:
870	# - parent is the ID of the parent block
871	# Returns an arrayref to a list of hashrefs with the CIDR block, location, type,
872	# custID, SWIP flag, description, block ID, and master ID
873	sub listAllocations {
874	my $dbh = shift;
875	my %args = @_;
876
877	# Snag the allocations for this block
878	my $sth = $dbh->prepare("SELECT cidr,city,type,custid,swip,description,vrf,id,master_id".
879	" FROM allocations WHERE parent_id = ? AND type !~ '[mc]\$' ORDER BY cidr");
880	$sth->execute($args{parent});
881
882	# hack hack hack
883	# set up to flag swip=y records if they don't actually have supporting data in the customers table
884	my $custsth = $dbh->prepare("SELECT count(*) FROM customers WHERE custid = ?");
885
886	my @blocklist;
887	while (my ($cidr,$city,$type,$custid,$swip,$desc,$vrf,$id,$mid) = $sth->fetchrow_array()) {
888	$desc .= " - vrf:$vrf" if $desc && $vrf;
889	$desc = "vrf:$vrf" if !$desc && $vrf;
890	$custsth->execute($custid);
891	my ($ncust) = $custsth->fetchrow_array();
892	my %row = (
893	block => $cidr,
894	city => $city,
895	type => $disp_alloctypes{$type},
896	custid => $custid,
897	swip => ($swip eq 'y' ? 'Yes' : 'No'),
898	partswip => ($swip eq 'y' && $ncust == 0 ? 1 : 0),
899	desc => $desc,
900	id => $id,
901	);
902	# $row{subblock} = ($type =~ /^.r$/); # hmf. wonder why these won't work in the hash declaration...
903	$row{listpool} = ($type =~ /^.[pd]$/);
904	push (@blocklist, \%row);
905	}
906	return \@blocklist;
907	} # end listAllocations()
908
909
910	## IPDB::listForMerge()
911	# Get a list of blocks targetted in a proposed merge
912	sub listForMerge {
913	my $dbh = shift;
914	my $parent = shift;
915	my $newblock = shift;
916	my $btype = shift \|\| 'a';
917	$btype = 'a' if $btype !~/^[af]$/;
918
919	my $sql;
920	if ($btype eq 'a') {
921	my $ret = $dbh->selectall_arrayref(q(
922	SELECT a.cidr,a.id,t.dispname FROM allocations a
923	JOIN alloctypes t ON a.type=t.type
924	WHERE a.parent_id = ? AND a.cidr <<= ?
925	ORDER BY a.cidr
926	),
927	{ Slice => {} }, $parent, $newblock);
928	return $ret;
929	} else {
930	##fixme: Not sure about the casting hackery in "SELECT ?::integer AS id", but it works as intended
931	my $ret = $dbh->selectall_arrayref(q(
932	SELECT cidr,id FROM freeblocks
933	WHERE parent_id IN (SELECT ?::integer AS id UNION
934	SELECT id FROM allocations WHERE parent_id = ? AND cidr <<= ?
935	) AND cidr <<= ?
936	ORDER BY cidr
937	),
938	{ Slice => {} }, $parent, $parent, $newblock, $newblock) or print $dbh->errstr;
939	return $ret;
940	}
941	} # end listForMerge()
942
943
944	## IPDB::listFree()
945	# Gets a list of free blocks in the requested parent/master and VRF instance in both CIDR and range notation
946	# Takes a parent/master ID and an optional VRF specifier that defaults to empty.
947	# Returns an arrayref to a list of hashrefs containing the CIDR and range-notation blocks
948	# Returns some extra flags in the hashrefs for routed blocks, since those can have several subtypes
949	sub listFree {
950	my $dbh = shift;
951
952	my %args = @_;
953	# Just In Case
954	$args{vrf} = '' if !$args{vrf};
955
956	my $sth = $dbh->prepare(q(
957	SELECT f.cidr,f.id,allocations.cidr
958	FROM freeblocks f
959	LEFT JOIN allocations ON f.reserve_for = allocations.id
960	WHERE f.parent_id = ?
961	ORDER BY f.cidr
962	) );
963	# $sth->execute($args{parent}, $args{vrf});
964	$sth->execute($args{parent});
965	my @flist;
966	while (my ($cidr,$id,$resv) = $sth->fetchrow_array()) {
967	$cidr = new NetAddr::IP $cidr;
968	my %row = (
969	fblock => "$cidr",
970	frange => $cidr->range,
971	fbid => $id,
972	fbparent => $args{parent},
973	resv => $resv,
974	);
975	push @flist, \%row;
976	}
977	return \@flist;
978	} # end listFree()
979
980
981	## IPDB::listPool()
982	#
983	sub listPool {
984	my $dbh = shift;
985	my $pool = shift;
986
987	my $sth = $dbh->prepare("SELECT ip,custid,available,description,type,id".
988	" FROM poolips WHERE parent_id = ? ORDER BY ip");
989	$sth->execute($pool);
990	my @poolips;
991	while (my ($ip,$custid,$available,$desc,$type,$id) = $sth->fetchrow_array) {
992	my %row = (
993	ip => $ip,
994	custid => $custid,
995	available => $available,
996	desc => $desc,
997	delme => $available eq 'n',
998	parent => $pool,
999	id => $id,
1000	);
1001	push @poolips, \%row;
1002	}
1003	return \@poolips;
1004	} # end listPool()
1005
1006
1007	## IPDB::getMasterList()
1008	# Get a list of master blocks, optionally including last-modified timestamps
1009	# Takes an optional flag to indicate whether to include timestamps;
1010	# 'm' includes ctime, all others (suggest 'c') do not.
1011	# Returns an arrayref to a list of hashrefs
1012	sub getMasterList {
1013	my $dbh = shift;
1014	my $stampme = shift \|\| 'm'; # optional but should be set by caller for clarity
1015
1016	my $mlist = $dbh->selectall_arrayref("SELECT id,vrf,cidr AS master".($stampme eq 'm' ? ',modifystamp AS mtime' : '').
1017	" FROM allocations WHERE type='mm' ORDER BY cidr", { Slice => {} });
1018	return $mlist;
1019	} # end getMasterList()
1020
1021
1022	## IPDB::getTypeList()
1023	# Get an alloctype/description pair list suitable for dropdowns
1024	# Takes a flag to determine which general groups of types are returned
1025	# Returns an reference to an array of hashrefs
1026	sub getTypeList {
1027	my $dbh = shift;
1028	my $tgroup = shift \|\| 'a'; # technically optional, like this, but should
1029	# really be specified in the call for clarity
1030	my $seltype = shift \|\| '';
1031
1032	my $sql = "SELECT type,listname,type=? AS sel FROM alloctypes WHERE listorder <= 500";
1033	if ($tgroup eq 'n') {
1034	# grouping 'p' - all netblock types. These include routed blocks, containers (_c)
1035	# and contained (_r) types, dynamic-allocation ranges (_e), static IP pools (_d and _p),
1036	# and the "miscellaneous" cn, in, and en types.
1037	$sql .= " AND type NOT LIKE '_i'";
1038	} elsif ($tgroup eq 'p') {
1039	# grouping 'p' - primary allocation types. As with 'n' above but without the _r contained types.
1040	$sql .= " AND type NOT LIKE '_i' AND type NOT LIKE '_r'";
1041	} elsif ($tgroup eq 'c') {
1042	# grouping 'c' - contained types. These include all static IPs and all _r types.
1043	$sql .= " AND (type LIKE '_i' OR type LIKE '_r')";
1044	} elsif ($tgroup eq 'i') {
1045	# grouping 'i' - static IP types.
1046	$sql .= " AND type LIKE '_i'";
1047	} else {
1048	# grouping 'a' - all standard allocation types. This includes everything
1049	# but mm (present only as a formality). Make this the default.
1050	# ... whee! no extra WHERE clauses
1051	}
1052	$sql .= " ORDER BY listorder";
1053	my $tlist = $dbh->selectall_arrayref($sql, { Slice => {} }, $seltype);
1054	return $tlist;
1055	}
1056
1057
1058	## IPDB::getPoolSelect()
1059	# Get a list of pools matching the passed city and type that have 1 or more free IPs
1060	# Returns an arrayref to a list of hashrefs
1061	sub getPoolSelect {
1062	my $dbh = shift;
1063	my $iptype = shift;
1064	my $pcity = shift;
1065
1066	my ($ptype) = ($iptype =~ /^(.)i$/);
1067	return if !$ptype;
1068	$ptype .= '_';
1069
1070	my $plist = $dbh->selectall_arrayref( q(
1071	SELECT count(*) AS poolfree,p.pool AS poolblock, a.city AS poolcit
1072	FROM poolips p
1073	JOIN allocations a ON p.parent_id=a.id
1074	WHERE p.available='y' AND a.city = ? AND p.type LIKE ?
1075	GROUP BY p.pool,a.city
1076	),
1077	{ Slice => {} }, ($pcity, $ptype) );
1078	return $plist;
1079	} # end getPoolSelect()
1080
1081
1082	## IPDB::findAllocateFrom()
1083	# Find free block to add a new allocation from. (CIDR block version of pool select above, more or less)
1084	# Takes
1085	# - mask length
1086	# - allocation type
1087	# - POP city "parent"
1088	# - optional master-block restriction
1089	# - optional flag to allow automatic pick-from-private-network-ranges
1090	# Returns a string with the first CIDR block matching the criteria, if any
1091	sub findAllocateFrom {
1092	my $dbh = shift;
1093	my $maskbits = shift;
1094	my $type = shift;
1095	my $city = shift;
1096	my $pop = shift;
1097	my %optargs = @_;
1098
1099	my $failmsg = "No suitable free block found\n";
1100
1101	my @vallist;
1102	my $sql;
1103
1104	# Free pool IPs should be easy.
1105	if ($type =~ /^.i$/) {
1106	# User may get an IP from the wrong VRF. User should not be using admin tools to allocate static IPs.
1107	$sql = "SELECT id, ip, parent_id FROM poolips WHERE ip = ?";
1108	@vallist = ($optargs{gimme});
1109	} else {
1110
1111	## Set up the SQL to find out what freeblock we can (probably) use for an allocation.
1112	## Very large systems will require development of a reserve system (possibly an extension
1113	## of the reserve-for-expansion concept in https://secure.deepnet.cx/trac/ipdb/ticket/24?)
1114	## Also populate a value list for the DBI call.
1115
1116	@vallist = ($maskbits);
1117	$sql = "SELECT id,cidr,parent_id FROM freeblocks WHERE masklen(cidr) <= ?";
1118
1119	# cases, strict rules
1120	# .c -> container type
1121	# requires a routing container, fbtype r
1122	# .d -> DHCP/"normal-routing" static pool
1123	# requires a routing container, fbtype r
1124	# .e -> Dynamic-assignment connectivity
1125	# requires a routing container, fbtype r
1126	# .i -> error, can't allocate static IPs this way?
1127	# mm -> error, master block
1128	# rm -> routed block
1129	# requires master block, fbtype m
1130	# .n -> Miscellaneous usage
1131	# requires a routing container, fbtype r
1132	# .p -> PPP(oE) static pool
1133	# requires a routing container, fbtype r
1134	# .r -> contained type
1135	# requires a matching container, fbtype $1
1136	##fixme: strict-or-not flag
1137
1138	##fixme: config or UI flag for "Strict" mode
1139	# if ($strictmode) {
1140	if (0) {
1141	if ($type =~ /^(.)r$/) {
1142	push @vallist, $1;
1143	$sql .= " AND routed = ?";
1144	} elsif ($type eq 'rm') {
1145	$sql .= " AND routed = 'm'";
1146	} else {
1147	$sql .= " AND routed = 'r'";
1148	}
1149	}
1150
1151	# for PPP(oE) and container types, the POP city is the one attached to the pool.
1152	# individual allocations get listed with the customer city site.
1153	##fixme: chain cities to align roughly with a full layer-2 node graph
1154	$city = $pop if $type !~ /^.[pc]$/;
1155	if ($type ne 'rm' && $city) {
1156	$sql .= " AND city = ?";
1157	push @vallist, $city;
1158	}
1159	# Allow specifying an arbitrary full block, instead of a master
1160	if ($optargs{gimme}) {
1161	$sql .= " AND cidr >>= ?";
1162	push @vallist, $optargs{gimme};
1163	}
1164	# if a specific master was requested, allow the requestor to self->shoot(foot)
1165	if ($optargs{master} && $optargs{master} ne '-') {
1166	$sql .= " AND master_id = ?";
1167	# if $optargs{master} ne '-';
1168	push @vallist, $optargs{master};
1169	} else {
1170	# if a specific master was NOT requested, filter out the RFC 1918 private networks
1171	if (!$optargs{allowpriv}) {
1172	$sql .= " AND NOT (cidr <<= '192.168.0.0/16' OR cidr <<= '10.0.0.0/8' OR cidr <<= '172.16.0.0/12')";
1173	}
1174	}
1175	# Keep "reserved" blocks out of automatic assignment.
1176	##fixme: needs a UI flag or a config knob
1177	$sql .= " AND reserve_for = 0";
1178	# Sorting and limiting, since we don't (currently) care to provide a selection of
1179	# blocks to carve up. This preserves something resembling optimal usage of the IP
1180	# space by forcing contiguous allocations and free blocks as much as possible.
1181	$sql .= " ORDER BY masklen(cidr) DESC,cidr LIMIT 1";
1182	} # done setting up SQL for free CIDR block
1183
1184	my ($fbid,$fbfound,$fbparent) = $dbh->selectrow_array($sql, undef, @vallist);
1185	return $fbid,$fbfound,$fbparent;
1186	} # end findAllocateFrom()
1187
1188
1189	## IPDB::ipParent()
1190	# Get an IP's parent pool's details
1191	# Takes a database handle and IP
1192	# Returns a hashref to the parent pool block, if any
1193	sub ipParent {
1194	my $dbh = shift;
1195	my $block = shift;
1196
1197	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1198	" WHERE cidr >>= ? AND (type LIKE '_p' OR type LIKE '_d')", undef, ($block) );
1199	return $pinfo;
1200	} # end ipParent()
1201
1202
1203	## IPDB::subParent()
1204	# Get a block's parent's details
1205	# Takes a database handle and CIDR block
1206	# Returns a hashref to the parent container block, if any
1207	sub subParent {
1208	my $dbh = shift;
1209	my $block = shift;
1210
1211	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,custid,type,city,description FROM allocations".
1212	" WHERE cidr >>= ?", undef, ($block) );
1213	return $pinfo;
1214	} # end subParent()
1215
1216
1217	## IPDB::blockParent()
1218	# Get a block's parent's details
1219	# Takes a database handle and CIDR block
1220	# Returns a hashref to the parent container block, if any
1221	sub blockParent {
1222	my $dbh = shift;
1223	my $block = shift;
1224
1225	my $pinfo = $dbh->selectrow_hashref("SELECT cidr,city FROM routed".
1226	" WHERE cidr >>= ?", undef, ($block) );
1227	return $pinfo;
1228	} # end blockParent()
1229
1230
1231	## IPDB::getBreadCrumbs()
1232	# Retrieve the ID and CIDR of a block's parent(s) up to the master block
1233	# Returns an arrayref to a list of hashrefs with CIDR and block ID
1234	sub getBreadCrumbs {
1235	my $dbh = shift;
1236	my $parent = shift;
1237	my @result;
1238
1239	my $sth = $dbh-> prepare("SELECT cidr,type,id,parent_id FROM allocations WHERE id=?");
1240
1241	while ($parent != 0) {
1242	$sth->execute($parent);
1243	my ($cidr,$type,$id,$pid) = $sth->fetchrow_array;
1244	push @result, {cidr => $cidr, link => $id, ispool => ($type =~ /^.[dp]$/ ? 1 : 0)};
1245	$parent = $pid;
1246	}
1247
1248	return \@result;
1249	} # end getBread()
1250
1251
1252	## IPDB::getRoutedCity()
1253	# Get the city for a routed block.
1254	sub getRoutedCity {
1255	my $dbh = shift;
1256	my $block = shift;
1257
1258	my ($rcity) = $dbh->selectrow_array("SELECT city FROM routed WHERE cidr = ?", undef, ($block) );
1259	return $rcity;
1260	} # end getRoutedCity()
1261
1262
1263	## IPDB::allocateBlock()
1264	# Does all of the magic of actually allocating a netblock
1265	# Requires a database handle, and a hash containing the block to allocate, routing depth, custid,
1266	# type, city, block to allocate from, and optionally a description, notes, circuit ID,
1267	# and private data
1268	# Returns a success code and optional error message.
1269	sub allocateBlock {
1270	my $dbh = shift;
1271
1272	my %args = @_;
1273
1274	$args{cidr} = new NetAddr::IP $args{cidr};
1275
1276	$args{desc} = '' if !$args{desc};
1277	$args{notes} = '' if !$args{notes};
1278	$args{circid} = '' if !$args{circid};
1279	$args{privdata} = '' if !$args{privdata};
1280	$args{vrf} = '' if !$args{vrf};
1281	$args{vlan} = '' if !$args{vlan};
1282	$args{rdns} = '' if !$args{rdns};
1283
1284	# Could arguably allow this for eg /120 allocations, but end users who get a single v4 IP are
1285	# usually given a v6 /64, and most v6 addressing schemes need at least half that address space
1286	if ($args{cidr}->{isv6} && $args{rdns} =~ /\%/) {
1287	return ('FAIL','Reverse DNS template patterns are not supported for IPv6 allocations');
1288	}
1289
1290	my $sth;
1291
1292	# Snag the "type" of the freeblock and its CIDR
1293	my ($alloc_from_type, $alloc_from, $fbparent, $fcity, $fbmaster) =
1294	$dbh->selectrow_array("SELECT routed,cidr,parent_id,city,master_id FROM freeblocks WHERE id = ?",
1295	undef, $args{fbid});
1296	$alloc_from = new NetAddr::IP $alloc_from;
1297	return ('FAIL',"Failed to allocate $args{cidr}; intended free block was used by another allocation.")
1298	if !$fbparent;
1299	##fixme: fail here if !$alloc_from
1300	# also consider "lock for allocation" due to multistep allocation process
1301
1302	# To contain the error message, if any.
1303	my $msg = "Unknown error allocating $args{cidr} as '$disp_alloctypes{$args{type}}'";
1304
1305	# Enable transactions and error handling
1306	local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1307	local $dbh->{RaiseError} = 1; # step on our toes by accident.
1308
1309	if ($args{type} =~ /^.i$/) {
1310	$msg = "Unable to assign static IP $args{cidr} to $args{custid}";
1311	eval {
1312	if ($args{cidr}) { # IP specified
1313	my ($isavail) = $dbh->selectrow_array("SELECT available FROM poolips WHERE ip=?", undef, ($args{cidr}) );
1314	die "IP is not in an IP pool.\n"
1315	if !$isavail;
1316	die "IP already allocated. Deallocate and reallocate, or update the entry\n"
1317	if $isavail eq 'n';
1318	} else { # IP not specified, take first available
1319	($args{cidr}) = $dbh->selectrow_array("SELECT ip FROM poolips WHERE pool=? AND available='y' ORDER BY ip",
1320	undef, ($args{alloc_from}) );
1321	}
1322	$dbh->do("UPDATE poolips SET custid = ?, city = ?,available='n', description = ?, notes = ?, ".
1323	"circuitid = ?, privdata = ?, vrf = ?, rdns = ? ".
1324	"WHERE ip = ? AND parent_id = ?", undef,
1325	($args{custid}, $args{city}, $args{desc}, $args{notes},
1326	$args{circid}, $args{privdata}, $args{vrf}, $args{rdns},
1327	$args{cidr}, $args{parent}) );
1328
1329	# node hack
1330	if ($args{nodeid} && $args{nodeid} ne '') {
1331	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1332	}
1333	# end node hack
1334
1335	$dbh->commit; # Allocate IP from pool
1336	};
1337	if ($@) {
1338	$msg .= ": $@";
1339	eval { $dbh->rollback; };
1340	return ('FAIL', $msg);
1341	} else {
1342	_rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user});
1343	return ('OK', $args{cidr});
1344	}
1345
1346	} else { # end IP-from-pool allocation
1347
1348	if ($args{cidr} == $alloc_from) {
1349	# Easiest case- insert in one table, delete in the other, and go home. More or less.
1350	# insert into allocations values (cidr,custid,type,city,desc) and
1351	# delete from freeblocks where cidr='cidr'
1352	# For data safety on non-transaction DBs, we delete first.
1353
1354	eval {
1355	$msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1356
1357	# Insert the allocations entry
1358	$dbh->do("INSERT INTO allocations ".
1359	"(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)".
1360	" VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1361	($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city},
1362	$args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1363	my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1364
1365	# Munge freeblocks
1366	if ($args{type} =~ /^(.)[mc]$/) {
1367	# special case - block is a routed or container/"reserve" block
1368	my $rtype = $1;
1369	$dbh->do("UPDATE freeblocks SET routed = ?,city = ?,parent_id = ? WHERE id = ?",
1370	undef, ($rtype, $args{city}, $bid, $args{fbid}) );
1371	} else {
1372	# "normal" case
1373	$dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1374	}
1375
1376	# And initialize the pool, if necessary
1377	# PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1378	# "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1379	if ($args{type} =~ /^.p$/) {
1380	$msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1381	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1382	die $rmsg if $code eq 'FAIL';
1383	} elsif ($args{type} =~ /^.d$/) {
1384	$msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1385	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1386	die $rmsg if $code eq 'FAIL';
1387	}
1388
1389	# node hack
1390	if ($args{nodeid} && $args{nodeid} ne '') {
1391	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1392	}
1393	# end node hack
1394
1395	$dbh->commit; # Simple block allocation
1396	}; # end of eval
1397	if ($@) {
1398	$msg .= ": ".$@;
1399	eval { $dbh->rollback; };
1400	return ('FAIL',$msg);
1401	}
1402
1403	} else { # cidr != alloc_from
1404
1405	# Hard case. Allocation is smaller than free block.
1406
1407	# make sure new allocation is in fact within freeblock. sigh
1408	return ('FAIL',"Requested allocation $args{cidr} is not within $alloc_from")
1409	if !$alloc_from->contains($args{cidr});
1410	my $wantmaskbits = $args{cidr}->masklen;
1411	my $maskbits = $alloc_from->masklen;
1412
1413	my @newfreeblocks; # Holds free blocks generated from splitting the source freeblock.
1414
1415	# This determines which blocks will be left "free" after allocation. We take the
1416	# block we're allocating from, and split it in half. We see which half the wanted
1417	# block is in, and repeat until the wanted block is equal to one of the halves.
1418	my $i=0;
1419	my $tmp_from = $alloc_from; # So we don't munge $args{alloc_from}
1420	while ($maskbits++ < $wantmaskbits) {
1421	my @subblocks = $tmp_from->split($maskbits);
1422	$newfreeblocks[$i++] = (($args{cidr}->within($subblocks[0])) ? $subblocks[1] : $subblocks[0]);
1423	$tmp_from = ( ($args{cidr}->within($subblocks[0])) ? $subblocks[0] : $subblocks[1] );
1424	} # while
1425
1426	# Begin SQL transaction block
1427	eval {
1428	$msg = "Unable to allocate $args{cidr} as '$disp_alloctypes{$args{type}}'";
1429
1430	# Delete old freeblocks entry
1431	$dbh->do("DELETE FROM freeblocks WHERE id = ?", undef, ($args{fbid}) );
1432
1433	# Insert the allocations entry
1434	$dbh->do("INSERT INTO allocations ".
1435	"(cidr,parent_id,master_id,vrf,vlan,custid,type,city,description,notes,circuitid,privdata,rdns)".
1436	" VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?)", undef,
1437	($args{cidr}, $fbparent, $fbmaster, $args{vrf}, $args{vlan}, $args{custid}, $args{type}, $args{city},
1438	$args{desc}, $args{notes}, $args{circid}, $args{privdata}, $args{rdns}) );
1439	my ($bid) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
1440
1441	# Insert new list of smaller free blocks left over. Flag the one that matches the
1442	# masklength of the new allocation, if a reserve block was requested.
1443	$sth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id,reserve_for) ".
1444	"VALUES (?,?,?,?,?,?,?)");
1445	foreach my $block (@newfreeblocks) {
1446	$sth->execute($block, $fcity, $alloc_from_type, $args{vrf}, $fbparent, $fbmaster,
1447	($args{reserve} && $block->masklen == $wantmaskbits ? $bid : 0));
1448	}
1449
1450	# For routed/container types, add a freeblock within the allocated block so we can subdivide it further
1451	if ($args{type} =~ /(.)[mc]/) { # rm and .c types - containers
1452	my $rtype = $1;
1453	$sth->execute($args{cidr}, $args{city}, $rtype, $args{vrf}, $bid, $fbmaster, 0);
1454	}
1455
1456	# And initialize the pool, if necessary
1457	# PPPoE pools (currently dialup, DSL, and WiFi) get all IPs made available
1458	# "DHCP" or "real-subnet" pools have the net, gw, and bcast IPs removed.
1459	if ($args{type} =~ /^.p$/) {
1460	$msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1461	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "all", $bid);
1462	die $rmsg if $code eq 'FAIL';
1463	} elsif ($args{type} =~ /^.d$/) {
1464	$msg = "Could not initialize IPs in new $disp_alloctypes{$args{type}} $args{cidr}";
1465	my ($code,$rmsg) = initPool($dbh, $args{cidr}, $args{type}, $args{city}, "normal", $bid);
1466	die $rmsg if $code eq 'FAIL';
1467	}
1468
1469	# node hack
1470	if ($args{nodeid} && $args{nodeid} ne '') {
1471	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($args{cidr}, $args{nodeid}) );
1472	}
1473	# end node hack
1474
1475	$dbh->commit; # Complex block allocation
1476	}; # end eval
1477	if ($@) {
1478	$msg .= ": ".$@;
1479	eval { $dbh->rollback; };
1480	return ('FAIL',$msg);
1481	}
1482
1483	} # end fullcidr != alloc_from
1484
1485	# now we do the DNS dance for netblocks, if we have an RPC server to do it with and a pattern to use.
1486	_rpc('addOrUpdateRevRec', cidr => "$args{cidr}", name => $args{rdns}, rpcuser => $args{user})
1487	if $args{rdns};
1488
1489	# and the per-IP set, if there is one.
1490	_rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user});
1491
1492	return ('OK', 'OK');
1493
1494	} # end static-IP vs netblock allocation
1495
1496	} # end allocateBlock()
1497
1498
1499	## IPDB::initPool()
1500	# Initializes a pool
1501	# Requires a database handle, the pool CIDR, type, city, and a parameter
1502	# indicating whether the pool should allow allocation of literally every
1503	# IP, or if it should reserve network/gateway/broadcast IPs
1504	# Note that this is NOT done in a transaction, that's why it's a private
1505	# function and should ONLY EVER get called from allocateBlock()
1506	sub initPool {
1507	my ($dbh,undef,$type,$city,$class,$parent) = @_;
1508	my $pool = new NetAddr::IP $_[1];
1509
1510	# IPv6 does not lend itself to IP pools as supported
1511	return ('FAIL',"Refusing to create IPv6 static IP pool") if $pool->{isv6};
1512	# IPv4 pools don't make much sense beyond even /24. Allow up to 4096-host footshooting anyway.
1513	# NetAddr::IP won't allow more than a /16 (65k hosts).
1514	return ('FAIL',"Refusing to create oversized static IP pool") if $pool->masklen <= 20;
1515
1516	# Retrieve some odds and ends for defaults on the IPs
1517	my ($pcustid) = $dbh->selectrow_array("SELECT def_custid FROM alloctypes WHERE type=?", undef, ($type) );
1518	my ($vrf,$vlan,$master) = $dbh->selectrow_array("SELECT vrf,vlan,master_id FROM allocations WHERE id = ?",
1519	undef, ($parent) );
1520
1521	$type =~ s/[pd]$/i/;
1522	my $sth;
1523	my $msg;
1524
1525	# Trap errors so we can pass them back to the caller. Even if the
1526	# caller is only ever supposed to be local, and therefore already
1527	# trapping errors. >:(
1528	local $dbh->{AutoCommit} = 0; # These need to be local so we don't
1529	local $dbh->{RaiseError} = 1; # step on our toes by accident.
1530
1531	eval {
1532	# have to insert all pool IPs into poolips table as "unallocated".
1533	$sth = $dbh->prepare("INSERT INTO poolips (ip,custid,city,type,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1534
1535	# in case of pool extension by some means, we need to see what IPs were already inserted
1536	my $tmp1 = $dbh->selectall_arrayref("SELECT ip FROM poolips WHERE parent_id = ?", undef, $parent);
1537	my %foundips;
1538	foreach (@{$tmp1}) {
1539	$foundips{$_->[0]} = 1;
1540	}
1541
1542	# Dodge an edge case - pool where IPs have been "stolen" and turned into a netblock assignment.
1543	# We can't just "get all the current IPs, and add the missing ones", because some IPs are
1544	# legitimately missing (for stretchy values of "legitimately").
1545
1546	my $pdata = getBlockData($dbh, $parent);
1547	my $pcidr = new NetAddr::IP $pdata->{block};
1548
1549	if ($pcidr != $pool) {
1550	# enumerate the IPs from the old pool, flag them as "found", so we can iterate the entire
1551	# requested pool and still make sure we skip the IPs in the old pool - even if they've been
1552	# "stolen" by legacy netblocks.
1553	my @oldips = $pcidr->hostenum;
1554	# decide whether to start excluding existing IPs at the "gateway" or "gateway+1"
1555	my $ostart = ($pdata->{type} =~ /^.d$/ ? 1 : 0);
1556	for (my $i = $ostart; $i<= $#oldips; $i++) {
1557	$foundips{$oldips[$i]} = 1;
1558	}
1559	}
1560
1561	# enumerate the hosts in the IP range - everything except the first (net) and last (bcast) IP
1562	my @poolip_list = $pool->hostenum;
1563
1564	# always check/add IPs from gw+1 through bcast-1:
1565	# (but the set won't be in oooorderrrrr! <pout>)
1566	for (my $i=1; $i<=$#poolip_list; $i++) {
1567	my $baseip = $poolip_list[$i]->addr;
1568	if ($baseip !~ /\.(?:0\|255)$/ && !$foundips{$poolip_list[$i]}) {
1569	$sth->execute($baseip, $pcustid, $city, $type, $parent, $master);
1570	}
1571	}
1572
1573	# now do the special case - DSL/PPP blocks can use the "net", "gw", and "bcast" IPs.
1574	# we exclude .0 and .255 anyway, since while they'll mostly work, they will behave badly here and there.
1575	if ($class eq 'all') { # (DSL-ish block - all IPs available
1576	if ($pool->addr !~ /\.0$/) { # .0 causes weirdness.
1577	$sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr};
1578	}
1579	$sth->execute($poolip_list[0]->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$poolip_list[0]};
1580	$pool--;
1581	if ($pool->addr !~ /\.255$/) { # .255 can cause weirdness.
1582	$sth->execute($pool->addr, $pcustid, $city, $type, $parent, $master) unless $foundips{$pool->addr};
1583	}
1584	}
1585	# don't commit here! the caller may not be done.
1586	# $dbh->commit;
1587	};
1588	if ($@) {
1589	$msg = $@;
1590	# Don't roll back! It's up to the caller to handle this.
1591	# eval { $dbh->rollback; };
1592	return ('FAIL',$msg);
1593	} else {
1594	return ('OK',"OK");
1595	}
1596	} # end initPool()
1597
1598
1599	## IPDB::updateBlock()
1600	# Update an allocation
1601	# Takes all allocation fields in a hash
1602	sub updateBlock {
1603	my $dbh = shift;
1604	my %args = @_;
1605
1606	return ('FAIL', 'Missing block to update') if !$args{block};
1607
1608	# Spaces don't show up well in lots of places. Make sure they don't get into the DB.
1609	$args{custid} =~ s/^\s+//;
1610	$args{custid} =~ s/\s+$//;
1611
1612	# do it all in a transaction
1613	local $dbh->{AutoCommit} = 0;
1614	local $dbh->{RaiseError} = 1;
1615
1616	my @fieldlist;
1617	my @vallist;
1618	foreach ('custid', 'city', 'description', 'notes', 'circuitid', 'privdata', 'rdns', 'vrf', 'vlan') {
1619	if ($args{$_}) {
1620	push @fieldlist, $_;
1621	push @vallist, $args{$_};
1622	}
1623	}
1624
1625	my $binfo;
1626	my $updtable = 'allocations';
1627	my $keyfield = 'id';
1628	if ($args{type} =~ /^(.)i$/) {
1629	$updtable = 'poolips';
1630	$binfo = getBlockData($dbh, $args{block}, 'i');
1631	} else {
1632	## fixme: there's got to be a better way...
1633	$binfo = getBlockData($dbh, $args{block});
1634	if ($args{swip}) {
1635	if ($args{swip} eq 'on' \|\| $args{swip} eq '1' \|\| $args{swip} eq 'y') {
1636	$args{swip} = 'y';
1637	} else {
1638	$args{swip} = 'n';
1639	}
1640	}
1641	foreach ('type', 'swip') {
1642	if ($args{$_}) {
1643	push @fieldlist, $_;
1644	push @vallist, $args{$_};
1645	}
1646	}
1647	}
1648
1649	return ('FAIL', 'No fields to update') if !@fieldlist;
1650
1651	my $sql = "UPDATE $updtable SET ";
1652	$sql .= join " = ?, ", @fieldlist;
1653
1654	eval {
1655	# check for block merge first...
1656	if ($args{fbmerge}) {
1657	my $cidr = NetAddr::IP->new($binfo->{block});
1658	my $newblock = NetAddr::IP->new($cidr->addr, $cidr->masklen - 1)->network;
1659	# safety net? make sure mergeable block passed in is really one or both of
1660	# a) reserved for expansion of the block and
1661	# b) confirmed CIDR-combinable
1662	# "safety? SELECT foo FROM freeblocks WHERE cidr << ? AND masklen(cidr) = ?, $newblock, ".$cidr->masklen."\n";
1663	$dbh->do("DELETE FROM freeblocks WHERE id=?", undef, $args{fbmerge});
1664	# ... so we can append the change in the stored CIDR field to extend the allocation.
1665	$sql .= " = ?, cidr";
1666	push @vallist, $newblock;
1667	# if we have an IP pool, call initPool to fill in any missing entries in the pool
1668	if ($binfo->{type} =~ /^.p$/) {
1669	my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'all', $args{block});
1670	die $rmsg if $code eq 'FAIL';
1671	} elsif ($binfo->{type} =~ /^.d$/) {
1672	my ($code,$rmsg) = initPool($dbh, "$newblock", $binfo->{type}, $binfo->{city}, 'normal', $args{block});
1673	die $rmsg if $code eq 'FAIL';
1674	}
1675	}
1676
1677	# append another SQL fragment
1678	push @vallist, $args{block};
1679	$sql .= " = ? WHERE $keyfield = ?";
1680
1681	# do the update
1682	$dbh->do($sql, undef, @vallist);
1683
1684	if ($args{node}) {
1685	# done with delete/insert so we don't have to worry about funkyness updating a node ref that isn't there
1686	$dbh->do("DELETE FROM noderef WHERE block = ?", undef, ($binfo->{block}) );
1687	$dbh->do("INSERT INTO noderef (block,node_id) VALUES (?,?)", undef, ($binfo->{block}, $args{node}) )
1688	if $args{node} ne '--';
1689	}
1690
1691	$dbh->commit;
1692	};
1693	if ($@) {
1694	my $msg = $@;
1695	$dbh->rollback;
1696	return ('FAIL', $msg);
1697	}
1698
1699	# In case of any container (mainly master block), only update freeblocks so we don't stomp subs
1700	# (which would be the wrong thing in pretty much any case except "DELETE ALL EVARYTHING!!1!oneone!")
1701	if ($binfo->{type} =~ '.[mc]') {
1702	# Not using listFree() as it doesn't return quite all of the blocks wanted.
1703	# Retrieve the immediate free blocks
1704	my $sth = $dbh->prepare(q(
1705	SELECT cidr FROM freeblocks WHERE parent_id = ?
1706	UNION
1707	SELECT cidr FROM freeblocks f WHERE
1708	cidr = (SELECT cidr FROM allocations a WHERE f.cidr = a.cidr)
1709	AND master_id = ?
1710	) );
1711	$sth->execute($args{block}, $binfo->{master_id});
1712	my %fbset;
1713	while (my ($fb) = $sth->fetchrow_array) {
1714	$fbset{"host_$fb"} = $args{rdns};
1715	}
1716	# We use this RPC call instead of multiple addOrUpdateRevRec calls, since we don't
1717	# know how many records we'll be updating and more than 3-4 is far too slow. This
1718	# should be safe to call unconditionally.
1719	# Requires dnsadmin >= r678
1720	_rpc('updateRevSet', %fbset, rpcuser => $args{user});
1721
1722	} else {
1723	$binfo->{block} =~ s\|/32$\|\|;
1724	_rpc('addOrUpdateRevRec', cidr => $binfo->{block}, name => $args{rdns}, rpcuser => $args{user});
1725
1726	# and the per-IP set, if there is one.
1727	_rpc('updateRevSet', %{$args{iprev}}, rpcuser => $args{user}) if keys (%{$args{iprev}});
1728	}
1729
1730	return ('OK','OK');
1731	} # end updateBlock()
1732
1733
1734	## IPDB::splitBlock()
1735	# Splits an existing allocation into two or more smaller allocations based on a passed netmask
1736	# Duplicates all other data
1737	# Returns an arrayref to a list of hashrefs with ID and CIDR keys for the list of new allocations.
1738	# Should probably commit DNS magic to realign DNS data
1739	# Mostly works but may return Strange Things(TM) if used on a master block
1740	sub splitBlock {
1741	my $dbh = shift;
1742	my %args = @_;
1743	# my $id = shift;
1744	# my $basetype = shift;
1745	# my $newmask = shift;
1746
1747	##fixme: set errstr on errors so caller can suitably clue-by-four the user
1748	return if $args{basetype} ne 'b'; # only netblocks allowed!
1749
1750	my $binfo = getBlockData($dbh, $args{id});
1751	return if !$binfo;
1752
1753	return if $args{newmask} !~ /^\d+$/;
1754
1755	my @ret;
1756	my $block = new NetAddr::IP $binfo->{block};
1757	my $oldmask = $block->masklen;
1758
1759	# Fail if the block to split is "too small" - eg, can't split a v4 /32 at all
1760	# failure modes:
1761	# difference between $oldmask and $newmask is negative or 0
1762	if ($args{newmask} - $oldmask <= 0) {
1763	$errstr = "Can't split a /$oldmask allocation into /$args{newmask} pieces";
1764	return;
1765	}
1766	# # difference between $oldmask and $newmask is > n, for arbitrary n?
1767	# if ($newmask - $oldmask > 42) { # because 42
1768	# }
1769	# $oldmask > n, for arbitrary n? At least check limits of data type.
1770	if ($block->{isv6}) {
1771	if ($args{newmask} - $oldmask > 128) {
1772	$errstr = "Impossible IPv6 mask length /$args{newmask} requested";
1773	return;
1774	}
1775	} else {
1776	if ($args{newmask} - $oldmask > 32) {
1777	$errstr = "Impossible IPv4 mask length /$args{newmask} requested";
1778	return;
1779	}
1780	}
1781
1782	my @newblocks = $block->split($args{newmask});
1783
1784	local $dbh->{AutoCommit} = 0;
1785	local $dbh->{RaiseError} = 1;
1786
1787	eval {
1788	# line up a list of fields and values. Be nice if there was a handy way to do,
1789	# direct in SQL, something like
1790	# "INSERT INTO foo (f1,f2,f3) VALUES (newf1,(SELECT oldf2,oldf3 FROM foo WHERE baz))"
1791	my @fieldlist = qw(type city description notes circuitid privdata custid swip vrf vlan rdns parent_id master_id);
1792	my $fields_sql = join(',', @fieldlist);
1793	my @vals;
1794	foreach (@fieldlist) {
1795	push @vals, $binfo->{$_};
1796	}
1797	# note the first block in the split for return
1798	push @ret, {nid => $args{id}, nblock => "$newblocks[0]"};
1799
1800	# prepare
1801	my $idsth = $dbh->prepare("SELECT currval('allocations_id_seq')");
1802	my $allocsth = $dbh->prepare("INSERT INTO allocations (cidr, $fields_sql)".
1803	" VALUES (?".',?'x(scalar(@fieldlist)).")");
1804	my $nbsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
1805	my $upd_psth = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
1806	my $upd_msth = $dbh->prepare("UPDATE allocations SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
1807	my $fb_psth = $dbh->prepare("UPDATE freeblocks SET parent_id = ? WHERE parent_id = ? AND cidr <<= ?");
1808	my $fb_msth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ? AND cidr <<= ?");
1809	my $pool_psth = $dbh->prepare("UPDATE poolips SET parent_id = ? WHERE parent_id = ? AND ip << ?");
1810	my $pool_msth = $dbh->prepare("UPDATE poolips SET master_id = ? WHERE master_id = ? AND ip <<= ?");
1811
1812	# set up update of existing block
1813	$dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, ("$newblocks[0]", $args{id}) );
1814
1815	# axe the new bcast IP from the smaller pool at the "base" block, if it's a "normal" pool
1816	if ($binfo->{type} =~ /.d/) {
1817	$newblocks[0]--;
1818	$nbsth->execute($args{id}, $newblocks[0]->addr);
1819	}
1820
1821	# Loop over the new blocks that are not the base block
1822	for (my $i = 1; $i <= $#newblocks; $i++) {
1823	# add the new allocation
1824	$allocsth->execute($newblocks[$i], @vals);
1825	# fetch the ID of the entry we just added...
1826	$idsth->execute();
1827	my ($nid) = $idsth->fetchrow_array();
1828	# ... so we can pass back the list of blocks and IDs...
1829	push @ret, {nid => $nid, nblock => "$newblocks[$i]"};
1830	# axe the net, gw, and bcast IPs as necessary when splitting a "normal" pool
1831	if ($binfo->{type} =~ /.d/) {
1832	# net
1833	$nbsth->execute($args{id}, $newblocks[$i]->addr);
1834	$newblocks[$i]++;
1835	# gw
1836	$nbsth->execute($args{id}, $newblocks[$i]->addr);
1837	$newblocks[$i]--;
1838	$newblocks[$i]--;
1839	# bcast
1840	$nbsth->execute($args{id}, $newblocks[$i]->addr);
1841	$newblocks[$i]++;
1842	}
1843
1844	# Reparent allocations, freeblocks, and pool IPs.
1845	$upd_psth->execute($nid, $args{id}, $newblocks[$i]);
1846	$fb_psth->execute($nid, $args{id}, $newblocks[$i]);
1847	$pool_psth->execute($nid, $args{id}, $newblocks[$i]);
1848
1849	# Update master if we've split a master block
1850	if ($binfo->{type} eq 'mm') {
1851	$upd_msth->execute($nid, $args{id}, $newblocks[$i]);
1852	$fb_msth->execute($nid, $args{id}, $newblocks[$i]);
1853	$pool_msth->execute($nid, $args{id}, $newblocks[$i]);
1854	}
1855
1856	} # for (... @newblocks)
1857
1858	$dbh->commit;
1859	};
1860	if ($@) {
1861	$errstr = "Error splitting $binfo->{block}: $@";
1862	$dbh->rollback;
1863	return;
1864	}
1865	##fixme: RPC return code?
1866	# particularly useful in this case as there may be arbitrary combinations of pass, warn, fail
1867	# results from each of the update and add(s), which could get the user to prod dnsadmin to see what exploded
1868	my $foo = _rpc('splitTemplate', cidr => $binfo->{block}, newmask => $args{newmask}, rpcuser => $args{user});
1869
1870	return \@ret;
1871	} # end splitBlock()
1872
1873
1874	## IPDB::shrinkBlock()
1875	# Shrink an allocation to the passed CIDR block
1876	# Takes an allocation ID and a new CIDR
1877	# Returns an arrayref to a list of hashrefs with the ID and CIDR of the freed block(s)
1878	# Refuses to shrink "real netblock" pool types below /30
1879	sub shrinkBlock {
1880	my $dbh = shift;
1881	my $id = shift;
1882
1883	# just take the new CIDR spec; this way we can shrink eg .16/28 to .20/30 without extra contortions
1884	my $newblock = new NetAddr::IP shift;
1885
1886	if (!$newblock) {
1887	$errstr = "Can't shrink something that's not a netblock";
1888	return;
1889	}
1890
1891	my $binfo = getBlockData($dbh, $id);
1892	my $pinfo = getBlockData($dbh, $binfo->{parent_id});
1893
1894	if ($binfo->{type} =~ /.d/ && $newblock->masklen > ($newblock->bits+2) ) {
1895	$errstr = "Can't shrink a non-PPP pool smaller than ".($newblock->{isv6} ? '/124' : '/30');
1896	return;
1897	}
1898
1899	my $oldblock = new NetAddr::IP $binfo->{block};
1900
1901	# Don't try to shrink the block outside of itself, Bad Things (probably) Happen.
1902	if (!$oldblock->contains($newblock)) {
1903	$errstr = "Can't shrink an allocation outside of itself";
1904	return;
1905	}
1906
1907	local $dbh->{AutoCommit} = 0;
1908	local $dbh->{RaiseError} = 1;
1909
1910	my $addfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
1911	my $idsth = $dbh->prepare("SELECT currval('freeblocks_id_seq')");
1912	my $poolsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip << ?");
1913	my $netsth = $dbh->prepare("DELETE FROM poolips WHERE parent_id = ? AND ip = ?");
1914	my $allocsth = $dbh->prepare("DELETE FROM allocations WHERE parent_id = ? AND cidr <<= ?");
1915	my $delfbsth = $dbh->prepare("DELETE FROM freeblocks WHERE parent_id = ? AND cidr <<= ?");
1916
1917	##fixme: turn this into a public/top-level sub?
1918	sub getchildren {
1919	my $dbh = shift;
1920	my $id = shift;
1921	my $master = shift;
1922	my $retlist = shift; # better than trying to return complex structures recursively. Ow.
1923	my $cidr = shift;
1924
1925	if (!$cidr) {
1926	my $bd = getBlockData($dbh, $id);
1927	$cidr = $bd->{cidr};
1928	}
1929
1930	my $sth = $dbh->prepare(q(
1931	SELECT id,cidr,type FROM allocations
1932	WHERE parent_id = ? AND master_id = ? AND cidr <<= ?
1933	) );
1934	$sth->execute($id, $master, $cidr);
1935	while (my $row = $sth->fetchrow_hashref) {
1936	push @$retlist, $row;
1937	getchildren($dbh, $row->{id}, $master, $retlist, $cidr);
1938	}
1939	}
1940
1941	my @ret;
1942	eval {
1943	$dbh->do("UPDATE allocations SET cidr = ? WHERE id = ?", undef, $newblock, $id);
1944
1945	# find the netblock(s) that are now free
1946	my @workingblocks = $oldblock->split($newblock->masklen);
1947	my @wb2;
1948	foreach my $newsub (@workingblocks) {
1949	next if $newsub == $newblock;
1950	push @wb2, $newsub;
1951	}
1952	@wb2 = Compact(@wb2);
1953
1954	# set new freeblocks, and clean up any IP pool entries if needed.
1955	foreach my $newfree (@wb2) {
1956	my @clist;
1957	# the block we're munging
1958	push @clist, { id => $id, type => $binfo->{type}, cidr => $binfo->{block} };
1959	getchildren($dbh, $id, $binfo->{master_id}, \@clist, $newfree);
1960
1961	foreach my $goner (@clist) {
1962	$poolsth->execute($goner->{id}, $newfree) if $goner->{type} =~ /.[dp]/;
1963	$allocsth->execute($goner->{id}, $newfree);
1964	$delfbsth->execute($goner->{id}, $newfree);
1965	}
1966
1967	# No pinfo means we're shrinking a master block, which means the free space is returned outside of IPDB.
1968	if ($pinfo) {
1969	$addfbsth->execute($newfree, $pinfo->{city}, 'm', $pinfo->{vrf}, $binfo->{parent_id}, $pinfo->{master_id});
1970	$idsth->execute;
1971	my ($nid) = $idsth->fetchrow_array();
1972	# add to return list
1973	push @ret, {fbid => $nid, newfree => "$newfree", fbparent => $binfo->{parent_id} };
1974	}
1975
1976	} # $newfree (@wb2)
1977
1978	# additional cleanup on net/gw/bcast IPs in pool
1979	if ($binfo->{type} =~ /.d/) {
1980	$netsth->execute($id, $newblock->addr);
1981	$newblock++;
1982	$netsth->execute($id, $newblock->addr);
1983	$newblock--;
1984	$newblock--;
1985	$netsth->execute($id, $newblock->addr);
1986	}
1987
1988	$dbh->commit;
1989	};
1990	if ($@) {
1991	$errstr = "Error splitting $binfo->{block}: $@";
1992	$dbh->rollback;
1993	return;
1994	}
1995
1996	return \@ret;
1997	} # end shrinkBlock()
1998
1999
2000	## IPDB::mergeBlocks()
2001	# Merges two or more adjacent allocations, optionally including relevant
2002	# free space, into one allocation.
2003	# Takes a "base" block ID and a hash with a mask length and a scope argument to decide
2004	# how much existing allocation data to delete.
2005	## Merge scope:
2006	# Merge to container
2007	# keepall
2008	# Move all mergeable allocations into the new block
2009	# Move all mergeable free blocks into the new block
2010	# mergepeer
2011	# Move subs of mergeable containers into the updated primary.
2012	# Reparent free blocks in mergeable containers to the updated primary.
2013	# Convert assigned IPs from pools into subs.
2014	# Convert unused IPs from pools into free blocks.
2015	# Convert leaf allocations into free blocks.
2016	# clearpeer
2017	# Keep subs of the original
2018	# Convert assigned IPs from pools into subs.
2019	# Convert unused IPs from pools into free blocks.
2020	# Convert leaf allocations into free blocks.
2021	# clearall
2022	# Delete all peers, subs and IPs.
2023	# Add single free block for new container.
2024	# Merge to pool
2025	# keepall
2026	# Convert all leaf allocations in the merge range to groups of used IPs
2027	# mergepeer
2028	# Effectively equal to keepall
2029	# clearpeer
2030	# Only convert IPs from the original allocation to used IPs
2031	# clearall
2032	# Delete any existing IPs, and reinitialize the new pool entirely
2033	# Merge to leaf type
2034	# Remove all subs
2035	sub mergeBlocks {
2036	my $dbh = shift;
2037	my $prime = shift; # "base" block ID to use as a starting point
2038	if (!$prime) {
2039	$errstr = "Missing block ID to base merge on";
2040	return;
2041	}
2042
2043	my %args = @_;
2044
2045	# check key arguments.
2046	if (!$args{scope} \|\| $args{scope} !~ /^(keepall\|mergepeer\|clearpeer\|clearall)$/) {
2047	$errstr = "Bad or missing merge scope";
2048	return;
2049	}
2050	if (!$args{newmask} \|\| $args{newmask} !~ /^\d+$/) {
2051	$errstr = "Bad or missing new netmask";
2052	return;
2053	}
2054
2055	# Retrieve info about the base allocation we're munging
2056	my $binfo = getBlockData($dbh, $prime);
2057	my $block = new NetAddr::IP $binfo->{block};
2058	my ($basetype) = ($binfo->{type} =~ /^.(.)$/);
2059	$binfo->{id} = $prime; # preserve for later, just in case
2060
2061	# proposed block
2062	my $newblock = new NetAddr::IP $block->addr."/$args{newmask}";
2063	$newblock = $newblock->network;
2064	$args{newtype} = $binfo->{type} if !$args{newtype};
2065	# if the "primary" block being changed is a master, it must remain one.
2066	$args{newtype} = 'mm' if $binfo->{type} eq 'mm';
2067	my ($newcontainerclass) = ($args{newtype} =~ /^(.).$/);
2068
2069	# build an info hash for the "new" allocation we're creating
2070	my $pinfo = {
2071	id => $prime,
2072	block => "$newblock",
2073	type => $args{newtype},
2074	parent_id =>
2075	$binfo->{parent_id},
2076	city => $binfo->{city},
2077	vrf => $binfo->{vrf},
2078	master_id => $binfo->{master_id}
2079	};
2080
2081	my @retlist;
2082
2083	local $dbh->{AutoCommit} = 0;
2084	local $dbh->{RaiseError} = 1;
2085
2086	# Want to do all of the DB stuff in a transaction, to minimize data changing underfoot
2087	eval {
2088
2089	# We always update the "prime" block passed in...
2090	$dbh->do("UPDATE allocations SET cidr = ?, type = ? WHERE id = ?", undef,
2091	($newblock, $args{newtype}, $prime) )
2092	# ... but only on existing container or pool types. Leaf -> container conversions
2093	# may need a new parent inserted instead.
2094	if $basetype =~ /[cm]/;
2095
2096	# For leaf blocks, we may need to create a new parent as the "primary" instead
2097	# of updating the existing block
2098	my $newparent = $dbh->prepare(q{
2099	INSERT INTO allocations (
2100	cidr, type, city, description, notes, circuitid, createstamp, modifystamp,
2101	privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id
2102	)
2103	SELECT
2104	? AS cidr, ? AS type, city, description, notes, circuitid, createstamp, modifystamp,
2105	privdata, custid, swip, vrf, vlan, rdns, parent_id, master_id
2106	FROM allocations
2107	WHERE id = ?
2108	});
2109
2110	# Common actions
2111	my $peersth = $dbh->prepare("SELECT cidr,id,type,master_id FROM allocations WHERE parent_id = ? AND cidr <<= ?");
2112	$peersth->execute($binfo->{parent_id}, "$newblock");
2113	my $reparentsth = $dbh->prepare("UPDATE allocations SET parent_id = ?, master_id = ? WHERE id = ?");
2114	my $insfbsth = $dbh->prepare("INSERT INTO freeblocks (cidr,city,routed,vrf,parent_id,master_id) VALUES (?,?,?,?,?,?)");
2115
2116	my $fbreparentsth = $dbh->prepare(q{
2117	UPDATE freeblocks
2118	SET parent_id = ?, master_id = ?, city = ?, routed = ?, vrf = ?
2119	WHERE parent_id = ? AND cidr <<= ?
2120	});
2121
2122	if ($args{newtype} =~ /.[cm]/) {
2123	## Container
2124
2125	# In case of merging a master block
2126	my $mfbsth = $dbh->prepare("UPDATE freeblocks SET master_id = ? WHERE master_id = ?");
2127
2128	if ($args{scope} eq 'keepall') {
2129	# Create a new parent with the same info as the passed "primary".
2130	$newparent->execute($newblock, $args{newtype}, $prime);
2131	# and now retrieve the new parent ID
2132	($prime) = $dbh->selectrow_array("SELECT currval('allocations_id_seq')");
2133	# Reparent the free blocks in the new block
2134	$fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2135	$binfo->{parent_id}, $newblock);
2136	# keep existing allocations (including the original primary), just push them down a level
2137	while (my ($pcidr,$peer_id,$ptype,$m_id) = $peersth->fetchrow_array) {
2138	$reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2139	# Fix up master_id on free blocks if we're merging a master block
2140	$mfbsth->execute($binfo->{master_id}, $m_id) if $ptype eq 'mm';
2141	}
2142
2143	} elsif ($args{scope} =~ /^clear/) {
2144	# clearpeer and clearall share a starting point
2145	# update the primary allocation info
2146	$dbh->do("UPDATE allocations SET cidr = ?, type = ? WHERE id = ?", undef, ($newblock, $args{newtype}, $prime) );
2147	# Reparent the free blocks in the new block
2148	$fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2149	$binfo->{parent_id}, $newblock);
2150	# Insert a free block if $prime is a leaf
2151	if ($binfo->{type} =~ /.[enr]/) {
2152	$insfbsth->execute($binfo->{block}, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $prime,
2153	$binfo->{master_id});
2154	}
2155	# delete the peers
2156	while (my ($pcidr,$peer_id) = $peersth->fetchrow_array) {
2157	next if $peer_id == $prime;
2158	# push existing allocations down a level before deleting,
2159	# so that when they're deleted the parent info is correct
2160	$reparentsth->execute($prime, $binfo->{master_id}, $peer_id);
2161	_deleteCascade($dbh, $peer_id);
2162	# insert the freeblock _deleteCascade() (deliberately) didn't when deleting a master block.
2163	# aren't special cases fun?
2164	$dbh->do("INSERT INTO freeblocks (cidr,routed,parent_id,master_id) values (?,?,?,?)",
2165	undef, ($pcidr, 'm', $prime, $prime) ) if $binfo->{type} eq 'mm';
2166	}
2167	if ($args{scope} eq 'clearall') {
2168	# delete any subs of $prime as well
2169	my $substh = $dbh->prepare("SELECT cidr,id FROM allocations WHERE parent_id = ?");
2170	$substh->execute($prime);
2171	while (my ($scidr, $s_id) = $substh->fetchrow_array) {
2172	_deleteCascade($dbh, $s_id);
2173	}
2174	} else {
2175	# clearpeer
2176	if ($basetype =~ /[dp]/) {
2177	# Convert active IP pool entries to allocations if the original was an IP pool
2178	_poolToAllocations($dbh, $binfo, $pinfo, newtype => $poolmap{$binfo->{type}});
2179	}
2180	} # clearall or clearpeer
2181
2182	} elsif ($args{scope} eq 'mergepeer') { # should this just be an else?
2183	# Default case. Merge "peer" blocks, but keep all suballocations
2184	my $substh = $dbh->prepare("UPDATE allocations SET parent_id = ? WHERE parent_id = ?");
2185	my $delsth = $dbh->prepare("DELETE FROM allocations WHERE id = ?");
2186	# Reparent freeblocks in parent
2187	$fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass, $binfo->{vrf},
2188	$binfo->{parent_id}, $newblock);
2189	# Loop over "peer" allocations to be merged
2190	while (my ($peercidr, $peer_id, $peertype, $m_id) = $peersth->fetchrow_array) {
2191	# Snag existing peer data since we may need it
2192	my $peerfull = getBlockData($dbh, $peer_id);
2193	# Reparent free blocks from existing containers
2194	$fbreparentsth->execute($prime, $binfo->{master_id}, $binfo->{city}, $newcontainerclass,
2195	$binfo->{vrf}, $peer_id, $newblock);
2196	# Reparent any subblocks from existing containers
2197	$substh->execute($prime, $peer_id);
2198	# Delete the old container
2199	$delsth->execute($peer_id) unless $peer_id == $prime;
2200	# Add new freeblocks for merged leaf blocks
2201	$insfbsth->execute($peercidr, $binfo->{city}, $newcontainerclass, $binfo->{vrf}, $binfo->{id},
2202	$binfo->{master_id}) if $peertype =~ /.[enr]/;
2203	# Convert pool IPs into allocations or aggregated free blocks
2204	_poolToAllocations($dbh, $peerfull, $pinfo, newparent => $prime) if $peertype =~ /.[dp];
2205	# Fix up master_id on free blocks if we're merging a master block
2206	$mfbsth->execute($binfo->{master_id}, $m_id) if $peertype eq 'mm';
2207	} # merge peers
2208	# update the primary allocation info. Do this last so we don't stomp extra data-retrieval in the loop above
2209	$dbh->do("UPDATE allocations SET cidr = ?, type = ? WHERE id = ?", undef, ($newblock, $args{newtype}, $prime) );
2210
2211	} # scope
2212
2213	# Clean up free blocks
2214	_compactFree($dbh, $prime);
2215
2216	} elsif ($args{newtype} =~ /.[dp]/) {
2217	## Pool
2218
2219	} elsif ($args{newtype} =~ /.[enr]/) {
2220	## Leaf
2221
2222	} # new type if()
2223
2224	$dbh->commit;
2225	};
2226	if ($@) {
2227	my $msg = $@;
2228	$errstr = $msg;
2229	$dbh->rollback;
2230	return ('FAIL',$msg);
2231	}
2232
2233	return \@retlist;
2234
2235	} # end mergeBlocks()
2236
2237
2238	## IPDB::deleteBlock()
2239	# Removes an allocation from the database, including deleting IPs
2240	# from poolips and recombining entries in freeblocks if possible
2241	# Also handles "deleting" a static IP allocation, and removal of a master
2242	# Requires a database handle, the block to delete, the routing depth (if applicable),
2243	# the VRF ID, and a flag to indicate whether to delete associated forward DNS entries
2244	# as well as the reverse entry
2245	sub deleteBlock {
2246	my ($dbh,$id,$basetype,$delfwd,$user) = @_;
2247
2248	# Collect info about the block we're going to delete
2249	my $binfo = getBlockData($dbh, $id, $basetype);
2250	my $cidr = new NetAddr::IP $binfo->{block};
2251
2252	# For possible auto-VRF-ignoring (since public IPs shouldn't usually be present in more than one VRF)
2253	# is_rfc1918 requires NetAddr::IP >= 4.059
2254	# rather than doing this over and over and over.....
2255	my $tmpnum = $cidr->numeric;
2256	# 192.168.0.0/16 -> 192.168.255.255 => 3232235520 -> 3232301055
2257	# 172.16.0.0/12 -> 172.31.255.255 => 2886729728 -> 2887778303
2258	# 10.0.0.0/8 -> 10.255.255.255 => 167772160 -> 184549375
2259	my $isprivnet = (3232235520 <= $tmpnum && $tmpnum <= 3232301055) \|\|
2260	(2886729728 <= $tmpnum && $tmpnum <= 2887778303) \|\|
2261	(167772160 <= $tmpnum && $tmpnum <= 184549375);
2262
2263	my $sth;
2264
2265	# Magic variables used for odd allocation cases.
2266	my $container;
2267	my $con_type;
2268
2269
2270	# temporarily forced null, until a sane UI for VRF tracking can be found.
2271	# $vrf = '';# if !$vrf; # as with SQL, the null value is not equal to ''. sigh
2272
2273	# To contain the error message, if any.
2274	my $msg = "Unknown error deallocating $binfo->{type} $cidr";
2275	my $goback; # to put the parent in so we can link back where the deallocate started
2276
2277	# Enable transactions and exception-on-errors... but only for this sub
2278	local $dbh->{AutoCommit} = 0;
2279	local $dbh->{RaiseError} = 1;
2280
2281	if ($binfo->{type} =~ /^.i$/) {
2282	# First case. The "block" is a static IP
2283	# Note that we still need some additional code in the odd case
2284	# of a netblock-aligned contiguous group of static IPs
2285
2286	eval {
2287	$msg = "Unable to deallocate $disp_alloctypes{$binfo->{type}} $cidr";
2288	my $pinfo = getBlockData($dbh, $binfo->{parent_id}, 'b');
2289	##fixme: VRF and rdepth
2290	$dbh->do("UPDATE poolips SET custid = ?, available = 'y',".
2291	"city = (SELECT city FROM allocations WHERE id = ?),".
2292	"description = '', notes = '', circuitid = '', vrf = ? WHERE id = ?", undef,
2293	($pinfo->{custid}, $binfo->{parent_id}, $pinfo->{vrf}, $id) );
2294	$dbh->commit;
2295	};
2296	if ($@) {
2297	$msg .= ": $@";
2298	eval { $dbh->rollback; };
2299	return ('FAIL',$msg);
2300	} else {
2301	##fixme: RPC return code?
2302	_rpc('delByCIDR', cidr => "$cidr", user => $user, delforward => $delfwd, rpcuser => $user);
2303	return ('OK',"OK");
2304	}
2305
2306	} elsif ($binfo->{type} eq 'mm') { # end alloctype =~ /.i/
2307	# Second case. The block is a full master block
2308
2309	##fixme: VRF limit
2310	$msg = "Unable to delete master block $cidr";
2311	eval {
2312	$dbh->do("DELETE FROM allocations WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
2313	$dbh->do("DELETE FROM freeblocks WHERE cidr <<= ? AND master_id = ?", undef, ($cidr, $binfo->{master_id}) );
2314	$dbh->commit;
2315	};
2316	if ($@) {
2317	$msg .= ": $@";
2318	eval { $dbh->rollback; };
2319	return ('FAIL', $msg);
2320	}
2321
2322	# Have to handle potentially split reverse zones. Assume they are split,
2323	# since if we added them here, they would have been added split.
2324	# allow splitting reverse zones to be disabled, maybe, someday
2325	#if ($splitrevzones && !$cidr->{isv6}) {
2326	my @zonelist;
2327	if (1 && !$cidr->{isv6}) {
2328	my $splitpoint = ($cidr->masklen <= 16 ? 16 : 24); # hack pthui
2329	@zonelist = $cidr->split($splitpoint);
2330	} else {
2331	@zonelist = ($cidr);
2332	}
2333	my @fails;
2334	foreach my $subzone (@zonelist) {
2335	if ($rpc_url && !_rpc('delZone', zone => "$subzone", revrec => 'y', rpcuser => $user, delforward => $delfwd) ) {
2336	push @fails, ("$subzone" => $errstr);
2337	}
2338	}
2339	if (@fails) {
2340	return ('WARN',"Warning(s) deleting $cidr from reverse DNS:\n".join("\n", @fails));
2341	}
2342	return ('OK','OK');
2343
2344	} else { # end alloctype master block case
2345
2346	## This is a big block; but it HAS to be done in a chunk. Any removal
2347	## of a netblock allocation may result in a larger chunk of free
2348	## contiguous IP space - which may in turn be combined into a single
2349	## netblock rather than a number of smaller netblocks.
2350
2351	my $retcode = 'OK';
2352	my ($ptype,$pcity,$ppatt,$p_id);
2353
2354	eval {
2355
2356	##fixme: add recursive flag to allow "YES DAMMIT DELETE ALL EVARYTHING!!1!!" without
2357	# explicitly deleting any suballocations of the block to be deleted.
2358
2359	# get parent info of the block we're deleting
2360	my $pinfo = getBlockData($dbh, $binfo->{parent_id});
2361	$ptype = $pinfo->{type};
2362	$pcity = $pinfo->{city};
2363	$ppatt = $pinfo->{rdns};
2364	$p_id = $binfo->{parent_id};
2365
2366	# Delete the block
2367	$dbh->do("DELETE FROM allocations WHERE id = ?", undef, ($id) );
2368
2369	# munge the parent type a little
2370	$ptype = (split //, $ptype)[1];
2371
2372	##fixme: you can't... CAN NOT.... assign the same public IP to multiple things.
2373	# 'Net don't work like that, homey. Restrict VRF-uniqueness to private IPs?
2374	# -> $isprivnet flag from start of sub
2375
2376	# check to see if any container allocations could be the "true" parent
2377	my ($tparent,$tpar_id,$trtype,$tcity);
2378	$tpar_id = 0;
2379
2380	##fixme: this is far simpler in the strict VRF case; we "know" that any allocation
2381	# contained by a container is a part of the same allocation tree when the VRF fields are equal.
2382
2383	# logic:
2384	# For each possible container of $cidr
2385	# note the parent id
2386	# walk the chain up the parents
2387	# if we intersect $cidr's current parent, break
2388	# if we've intersected $cidr's current parent
2389	# set some variables to track that block
2390	# break
2391
2392	# Set up part of "is it in the middle of a pool?" check
2393	my $wuzpool = $dbh->selectrow_hashref("SELECT cidr,parent_id,type,city,custid,id FROM allocations ".
2394	"WHERE (type LIKE '_d' OR type LIKE '_p') AND cidr >> ? AND master_id = ?", { Slice => {} },
2395	($cidr, $binfo->{master_id}) );
2396
2397	##fixme?
2398	# edge cases not handled, or handled badly:
2399	# -> $cidr managed to get to be the entirety of an IP pool
2400
2401	if ($wuzpool && $wuzpool->{id} != $id) {
2402	# we have legacy goo to be purified
2403	# going to ignore nested pools; not possible to create them via API and no current legacy data includes any.
2404
2405	# for convenience
2406	my $poolid = $wuzpool->{id};
2407	my $pool = $wuzpool->{cidr};
2408	my $poolcity = $wuzpool->{city};
2409	my $pooltype = $wuzpool->{type};
2410	my $poolcustid = $wuzpool->{custid};
2411
2412	$retcode = 'WARNPOOL';
2413	$goback = "$poolid,$pool";
2414	# We've already deleted the block, now we have to stuff its IPs into the pool.
2415	$pooltype =~ s/[dp]$/i/; # change type to static IP
2416	my $sth2 = $dbh->prepare("INSERT INTO poolips (ip,city,type,custid,parent_id) VALUES ".
2417	"(?,'$poolcity','$pooltype','$poolcustid',$poolid)");
2418
2419	##fixme: need to not insert net, gateway, and bcast on "real netblock" pools (DHCPish)
2420	# don't insert .0
2421	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.0$\|;
2422	$cidr++;
2423	my $bcast = $cidr->broadcast;
2424	while ($cidr != $bcast) {
2425	$sth2->execute($cidr->addr);
2426	$cidr++;
2427	}
2428	# don't insert .255
2429	$sth2->execute($cidr->addr) unless $cidr->addr =~ m\|\.255$\|;
2430
2431	# Weirdness Happens. $cidr goes read-only somewhere (this is a thing?!?),
2432	# causing ->split, ->hostenum, and related methods to explode. O_o
2433	# foreach my $ip ($cidr->hostenum) {
2434	# $sth2->execute($ip);
2435	# }
2436
2437	}
2438
2439	## important!
2440	# ... or IS IT?
2441	# we may have undef'ed $wuzpool above, if the allocation tree $cidr is in doesn't intersect the pool we found
2442	#if (!$wuzpool) {
2443
2444	else {
2445
2446	# Edge case: Block is the same size as more than one parent level. Should be rare.
2447	# - mainly master + first routing. Sorting on parent_id hides the problem pretty well,
2448	# but it's likely still possible to fail in particularly well-mangled databases.
2449	# The ultimate fix for this may be to resurrect the "routing depth" atrocity. :/
2450	# Get all possible (and probably a number of impossible) containers for $cidr
2451	$sth = $dbh->prepare("SELECT cidr,parent_id,type,city,id FROM allocations ".
2452	"WHERE (type LIKE '_m' OR type LIKE '_c') AND cidr >>= ? AND master_id = ? ".
2453	"ORDER BY masklen(cidr) DESC,parent_id DESC");
2454	$sth->execute($cidr, $binfo->{master_id});
2455
2456	# Quickly get certain fields (simpler than getBlockData()
2457	my $sth2 = $dbh->prepare("SELECT cidr,parent_id,type,city FROM allocations ".
2458	"WHERE (type LIKE '_m' OR type LIKE '_c') AND id = ? AND master_id = ?");
2459
2460	# For each possible container of $cidr...
2461	while (my @data = $sth->fetchrow_array) {
2462	my $i = 0;
2463	# Save some state and set a start point - parent ID of container we're checking
2464	$tparent = $data[0];
2465	my $ppid = $data[1];
2466	$trtype = $data[2];
2467	$tcity = $data[3];
2468	$tpar_id = $data[4];
2469	last if $data[4] == $binfo->{parent_id}; # Preemptively break if we're already in the right place
2470	last if $ppid == $binfo->{parent_id}; # ... or if the parent of the container is the block's parent
2471	while (1) {
2472	# Retrieve bits on that parent ID
2473	$sth2->execute($ppid, $binfo->{master_id});
2474	my @container = $sth2->fetchrow_array;
2475	$ppid = $container[1];
2476	last if $container[1] == 0; # Break if we've hit a master block
2477	last if $ppid == $binfo->{parent_id}; # Break if we've reached the block $cidr is currently in
2478	}
2479	last if $ppid == $binfo->{parent_id};
2480	}
2481
2482	# found an alternate parent; reset some parent-info bits
2483	if ($tpar_id != $binfo->{parent_id}) {
2484	$ptype = (split //, $trtype)[1];
2485	$pcity = $tcity;
2486	$retcode = 'WARNMERGE'; # may be redundant
2487	$p_id = $tpar_id;
2488	}
2489
2490	$goback = "$p_id,$tparent"; # breadcrumb, currently only used in case of live-parent-is-not-true-parent
2491
2492	# Special case - delete pool IPs
2493	if ($binfo->{type} =~ /^.[pd]$/) {
2494	# We have to delete the IPs from the pool listing.
2495	##fixme: rdepth? vrf?
2496	$dbh->do("DELETE FROM poolips WHERE parent_id = ?", undef, ($id) );
2497	}
2498
2499	$pinfo = getBlockData($dbh, $p_id);
2500
2501	# If the block wasn't legacy goo embedded in a static pool, we check the
2502	# freeblocks in the identified parent to see if we can combine any of them.
2503
2504	# if the block to be deleted is a container, move its freeblock(s) up a level, and reset their parenting info
2505	if ($binfo->{type} =~ /^.[mc]/) {
2506	# move the freeblocks into the parent
2507	# we don't insert a new freeblock because there could be a live reparented sub.
2508	$dbh->do("UPDATE freeblocks SET parent_id = ?, routed = ?, city = ? WHERE parent_id = ?", undef,
2509	($p_id, $ptype, $pcity, $id) );
2510	} else {
2511	# ... otherwise, add the freeblock
2512	$dbh->do("INSERT INTO freeblocks (cidr, city, routed, parent_id, master_id) VALUES (?,?,?,?,?)", undef,
2513	($cidr, $pcity, $ptype, $p_id, $binfo->{master_id}) );
2514	}
2515
2516	# Walk the free blocks in the parent and reduce them to the minimal set of CIDR ranges necessary
2517	_compactFree($dbh, $p_id);
2518
2519	} # done returning IPs to the appropriate place
2520
2521	# If we got here, we've succeeded. Whew!
2522	$dbh->commit;
2523	}; # end eval
2524	if ($@) {
2525	$msg .= ": $@";
2526	eval { $dbh->rollback; };
2527	return ('FAIL', $msg);
2528	} else {
2529	##fixme: RPC return code?
2530	_rpc('delByCIDR', cidr => "$cidr", rpcuser => $user, delforward => $delfwd, delsubs => 'y', parpatt => $ppatt);
2531	return ($retcode, $goback);
2532	}
2533
2534	} # end alloctype != netblock
2535
2536	} # end deleteBlock()
2537
2538
2539	## IPDB::getBlockData()
2540	# Get CIDR or IP, custid, type, city, circuit ID, description, notes, modification time,
2541	# private/restricted data, for a CIDR block or pool IP
2542	# Also returns SWIP status flag for CIDR blocks or pool netblock for IPs
2543	# Takes the block ID or IP to look up and an optional flag to indicate a pool IP lookup
2544	# instead of a netblock.
2545	# Returns a hashref to the block data
2546	sub getBlockData {
2547	my $dbh = shift;
2548	my $id = shift;
2549	my $type = shift \|\| 'b'; # default to netblock for lazy callers
2550
2551	# netblocks are in the allocations table; pool IPs are in the poolips table.
2552	# If we try to look up a CIDR in an integer field we should just get back nothing.
2553	my ($btype) = $dbh->selectrow_array("SELECT type FROM allocations WHERE id=?", undef, ($id) );
2554
2555	# Note city, vrf, parent_id and master_id removed due to JOIN uncertainty for block allocations
2556	my $commonfields = q(custid, type, circuitid, description, notes, modifystamp AS lastmod,
2557	privdata, vlan, rdns);
2558
2559	if ($type eq 'i') {
2560	my $binfo = $dbh->selectrow_hashref(qq(
2561	SELECT id, ip AS block, city, vrf, parent_id, master_id, $commonfields
2562	FROM poolips WHERE id = ?
2563	), undef, ($id) );
2564	return $binfo;
2565	} else {
2566	my $binfo = $dbh->selectrow_hashref(qq(
2567	SELECT a.id, a.cidr AS block, a.city, a.vrf, a.parent_id, a.master_id, swip, $commonfields,
2568	f.cidr AS reserve, f.id as reserve_id
2569	FROM allocations a LEFT JOIN freeblocks f ON a.id=f.reserve_for
2570	WHERE a.id = ?
2571	), undef, ($id) );
2572	return $binfo;
2573	}
2574	} # end getBlockData()
2575
2576
2577	## IPDB::getBlockRDNS()
2578	# Gets reverse DNS pattern for a block or IP. Note that this will also
2579	# retrieve any default pattern following the parent chain up, and check via
2580	# RPC (if available) to see what the narrowest pattern for the requested block is
2581	# Returns the current pattern for the block or IP.
2582	sub getBlockRDNS {
2583	my $dbh = shift;
2584	my %args = @_;
2585
2586	$args{type} = 'b' if !$args{type};
2587	my $cached = 1;
2588
2589	# snag entry from database
2590	my ($rdns,$rfrom,$pid);
2591	if ($args{type} =~ /.i/) {
2592	($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,ip,parent_id FROM poolips WHERE id = ?",
2593	undef, ($args{id}) );
2594	} else {
2595	($rdns, $rfrom, $pid) = $dbh->selectrow_array("SELECT rdns,cidr,parent_id FROM allocations WHERE id = ?",
2596	undef, ($args{id}) );
2597	}
2598
2599	# Can't see a way this could end up empty, for any case I care about. If the caller
2600	# doesn't know an allocation ID to request, then they don't know anything else anyway.
2601	my $selfblock = $rfrom;
2602
2603	my $type;
2604	while (!$rdns && $pid) {
2605	($rdns, $rfrom, $pid, $type) = $dbh->selectrow_array(
2606	"SELECT rdns,cidr,parent_id,type FROM allocations WHERE id = ?",
2607	undef, ($pid) );
2608	last if $type eq 'mm'; # break loops in unfortunate legacy data
2609	}
2610
2611	# use the actual allocation to check against the DNS utility; we don't want
2612	# to always go chasing up the chain to the master... which may (usually won't)
2613	# be present directly in DNS anyway
2614	my $cidr = new NetAddr::IP $selfblock;
2615
2616	if ($rpc_url) {
2617	# Use the first /16 or /24, rather than dithering over which sub-/14 /16
2618	# or sub-/19 /24 to retrieve - it's the least-wrong way to do things.
2619
2620	my ($rpcblock) = ($cidr->masklen <= 24 ? $cidr->split( ($cidr->masklen <= 16 ? 16 : 24) ) : $cidr);
2621	my %rpcargs = (
2622	rpcuser => $args{user},
2623	group => $revgroup, # not sure how this could sanely be exposed, tbh...
2624	cidr => "$rpcblock",
2625	);
2626
2627	my $remote_rdns = _rpc('getRevPattern', %rpcargs);
2628	$rdns = $remote_rdns if $remote_rdns;
2629	$cached = 0;
2630	}
2631
2632	# hmm. do we care about where it actually came from?
2633	return $rdns, $cached;
2634	} # end getBlockRDNS()
2635
2636
2637	## IPDB::getRDNSbyIP()
2638	# Get individual reverse entries for the IP or CIDR IP range passed. Sort of looking the
2639	# opposite direction down the netblock tree compared to getBlockRDNS() above.
2640	sub getRDNSbyIP {
2641	my $dbh = shift;
2642	my %args = @_; # We want to accept a variety of call types
2643
2644	# key arguments: allocation ID, type
2645	unless ($args{id} \|\| $args{type}) {
2646	$errstr = 'Missing allocation ID or type';
2647	return;
2648	}
2649
2650	my @ret = ();
2651	# special case: single IP. Check if it's an allocation or in a pool, then do the RPC call for fresh data.
2652	if ($args{type} =~ /^.i$/) {
2653	my ($ip, $localrev) = $dbh->selectrow_array("SELECT ip, rdns FROM poolips WHERE id = ?", undef, ($args{id}) );
2654	push @ret, { 'r_ip' => $ip, 'iphost' => $localrev };
2655	} else {
2656	if ($rpc_url) {
2657	my %rpcargs = (
2658	rpcuser => $args{user},
2659	group => $revgroup, # not sure how this could sanely be exposed, tbh...
2660	cidr => $args{range},
2661	);
2662
2663	my $remote_rdns = _rpc('getRevSet', %rpcargs);
2664	return $remote_rdns;
2665	# $rdns = $remote_rdns if $remote_rdns;
2666	# $cached = 0;
2667	}
2668	}
2669	return \@ret;
2670	} # end getRDNSbyIP()
2671
2672
2673	## IPDB::getNodeList()
2674	# Gets a list of node ID+name pairs as an arrayref to a list of hashrefs
2675	sub getNodeList {
2676	my $dbh = shift;
2677
2678	my $ret = $dbh->selectall_arrayref("SELECT node_id, node_name FROM nodes ORDER BY node_type,node_id",
2679	{ Slice => {} });
2680	return $ret;
2681	} # end getNodeList()
2682
2683
2684	## IPDB::getNodeName()
2685	# Get node name from the ID
2686	sub getNodeName {
2687	my $dbh = shift;
2688	my $nid = shift;
2689
2690	my ($nname) = $dbh->selectrow_array("SELECT node_name FROM nodes WHERE node_id = ?", undef, ($nid) );
2691	return $nname;
2692	} # end getNodeName()
2693
2694
2695	## IPDB::getNodeInfo()
2696	# Get node name and ID associated with a block
2697	sub getNodeInfo {
2698	my $dbh = shift;
2699	my $block = shift;
2700
2701	my ($nid, $nname) = $dbh->selectrow_array("SELECT nodes.node_id,node_name FROM nodes INNER JOIN noderef".
2702	" ON nodes.node_id=noderef.node_id WHERE noderef.block = ?", undef, ($block) );
2703	return ($nid, $nname);
2704	} # end getNodeInfo()
2705
2706
2707	## IPDB::mailNotify()
2708	# Sends notification mail to recipients regarding an IPDB operation
2709	sub mailNotify {
2710	my $dbh = shift;
2711	my ($action,$subj,$message) = @_;
2712
2713	return if $smtphost eq 'smtp.example.com'; # do nothing if still using default SMTP host.
2714
2715	##fixme: need to redesign the breakdown/processing for $action for proper handling of all cases
2716
2717	# split action into parts for fiddlement. nb: there are almost certainly better ways to do this.
2718	my @actionbits = split //, $action;
2719
2720	# want to notify anyone who has specifically requested notify on this type ($action as passed),
2721	# on "all static IP types" or "all pool types" (and other last-char-in-type groupings), on eg "all DSL types",
2722	# and "all events with this action"
2723	my @actionsets = ($action);
2724	##fixme: ick, eww. really gotta find a better way to handle this...
2725	push @actionsets, ($actionbits[0].'.'.$actionbits[2],
2726	$actionbits[0].$actionbits[1].'.', $actionbits[0].'a') if $action =~ /^.{3}$/;
2727
2728	my $mailer = Net::SMTP->new($smtphost, Hello => "ipdb.$domain");
2729
2730	# get recip list from db
2731	my $sth = $dbh->prepare("SELECT reciplist FROM notify WHERE action=?");
2732
2733	my %reciplist;
2734	foreach (@actionsets) {
2735	$sth->execute($_);
2736	##fixme - need to handle db errors
2737	my ($recipsub) = $sth->fetchrow_array;
2738	next if !$recipsub;
2739	foreach (split(/,/, $recipsub)) {
2740	$reciplist{$_}++;
2741	}
2742	}
2743
2744	return if !%reciplist;
2745
2746	foreach my $recip (keys %reciplist) {
2747	$mailer->mail($smtpsender);
2748	$mailer->to($recip);
2749	$mailer->data("From: \"$org_name IP Database\" <$smtpsender>\n",
2750	"To: $recip\n",
2751	"Date: ".strftime("%a, %d %b %Y %H:%M:%S %z",localtime)."\n",
2752	"Subject: {IPDB} $subj\n",
2753	"X-Mailer: IPDB Notify v".sprintf("%.1d",$IPDB::VERSION)."\n",
2754	"Organization: $org_name\n",
2755	"\n$message\n");
2756	}
2757	$mailer->quit;
2758	}
2759
2760	# Indicates module loaded OK. Required by Perl.
2761	1;

Note: See TracBrowser for help on using the repository browser.

Download in other formats: