#!/usr/local/bin/tclsh8.6

#
# Perform DNS zone generation for BIND
#
# Syntax:
#	mkzone [-h][-q][-v][-n] [-w <view-name>|<zone-name> ... <zone-name>]
#
# If zone names are supplied, zone generation is done only for these
# zones. Else, only modified zones (those which have the bit "gen")
# are generated.
# If view-name is given, zone generation is limited to modified zones 
# associated with this view.
#
# History:
#   2002/04/23 : pda/jean : specification
#   2002/04/23 : pda/jean : design
#   2002/05/23 : pda/jean : substution of %NAME% for supplementary RR
#   2004/01/14 : pda/jean : generation of IPv6 AAAA records
#   2004/03/09 : pda/jean : generation of mail roles
#   2008/12/09 : jean     : TTL management
#   2011/05/29 : pda      : i18n and re-design
#   2012/10/24 : pda/jean : add views
#

source /usr/local/lib/netmagis/libnetmagis.tcl

#
# Self explanatory
#

set conf(usage) {usage: %1$s [-h]|-q][-v][-n] [-w <view>|<zone-name> ... <zone-name>]
    -h : get this help
    -q : keep silent on normal operation
    -v : verbose (show diffs)
    -n : don't perform file installation
    -w <view> : limit generation to modified zones for this view
    <zone-name> ... : if supplied, force generation for these zones
}

#
# Return the list of zones which must be genareted (or the list of all zones)
#
# Input:
#   - dbfd: database handle
#   - idview: id of specified view, -1 if not specified
# Output:
#   - return value: list of zone names
#
# History:
#   2002/04/26 : pda/jean : design
#   2012/10/24 : pda/jean : add idview parameter and remove obsolete parameter
#

proc get-mod-zones {dbfd idview} {
    set crit "WHERE gen = 1"
    if {$idview != -1} then {
	append crit " AND idview = $idview"
    }
    set l {}
    pg_select $dbfd "SELECT name FROM dns.zone $crit" tab {
	lappend l $tab(name)
    }
    return $l
}

#
# Compute the new serial of a zone
#
# Input:
#   - serial: old serial number
# Output:
#   - return value: new serial number
#
# Algorithm (see issue #47):
#   if current serial is empty (new zone)
#	then new serial := ctoday concatenated with 00
#	else
#	     parse the current serial (from the zone_*.version column)
#	        to get yyyymmdd and nn
#            if yyyymmdd < today
#	 	 then new serial := ctoday concatenated with 00
#		 else new serial := serial + 1
#
#   Properties of this algorithm:
#	- the serial is strictly monotonic
#	- it follows the yyyymmddnn convention when possible
#		(for aestethic reasons)
#	- if there is one modification every minute, starting from
#		2012/09/20, this algorithm will overflow the 32-bit SOA
#		serial in 4343,37 years, so in year 6355.
#
# History:
#   2012/09/20 : pda/jean : design of the new auto-adaptative algorithm
#   2013/09/09 :     jean : fix initial value bug
#

proc new-serial {serial} {
    set today [clock format [clock seconds] -format "%Y%m%d"]
    if {$serial eq ""} then {
	set nserial "${today}00"
    } elseif {[regexp {^(\d{8})(\d{2})$} $serial dummy odate onn]} then {
	if {$odate < $today} then {
	    set nserial "${today}00"
	} else {
	    set nserial [expr $serial+1]
	}
    } else {
	set nserial [expr $serial+1]
    }

    return $nserial
}

#
# Generates zone content
#
# Input:
#   - dbfd: database handle
#   - zone: name of zone to generate
#   - _txt: in return, zone contents or error message
# Output:
#   - return value: 1 if ok, 0 if error
#   - parameter _txt: zone contents or error message
#
# History:
#   2002/04/26 : pda/jean : design
#   2002/05/02 : pda/jean : multiple "zone*" table with inheritance
#   2011/05/29 : pda      : interface change
#   2012/10/24 : pda/jean : add views
#

proc gen-zone {dbfd zone _txt} {
    upvar $_txt txt

    set qzone [::pgsql::quote $zone]

    set sql "SELECT n.nspname || '.' || c.relname AS table,
			zone.version, zone.prologue, zone.rrsup, zone.gen,
			zone.idview
		    FROM dns.zone, pg_class c, pg_namespace n
		    WHERE name = '$qzone'
			AND c.oid = zone.tableoid
			AND c.relnamespace = n.oid
			"
    set found 0
    pg_select $dbfd $sql tab {
	set table	$tab(table)	;# dns.zone_forward, dns.zone_reverse[46]
	set version	$tab(version)
	set prologue	$tab(prologue)
	set rrsup	$tab(rrsup)
	set gen		$tab(gen)
	set idview	$tab(idview)
	set found 1
    }

    #
    # Zone not found
    #

    if {! $found} then {
	set txt "Zone '$zone' not found"
	return 0
    }

    #
    # Get selection criterion
    #

    set sql "SELECT selection FROM $table WHERE name = '$qzone'" 
    pg_select $dbfd $sql tab {
	set selection	$tab(selection)
    }

    #
    # Compute the new version number for the zone
    #

    set nversion [new-serial $version]

    #
    # Generate prologue with version number
    #

    if {[regsub {%ZONEVERSION%} $prologue $nversion sprologue] != 1} then {
	set txt "zone '$zone': %ZONEVERSION% not found in prologue"
	return 0
    }

    set txt $sprologue
    append txt "\n"

    #
    # Distinguish generation format
    #

    switch -- $table {
	dns.zone_forward {
	    if {! [gen-fwd $dbfd $zone $selection $idview $rrsup txt]} then {
		return 0
	    }
	}
	dns.zone_reverse4 {
	    if {! [gen-ipv4 $dbfd $zone $selection $idview $rrsup txt]} then {
		return 0
	    }
	}
	dns.zone_reverse6 {
	    if {! [gen-ipv6 $dbfd $zone $selection $idview $rrsup txt]} then {
		return 0
	    }
	}
	default {
	    set txt "zone '$zone': invalid table ('$table')"
	    return 0
	}
    }

    #
    # End of generation: keep version number as well as zone is generated
    #

    set sql "UPDATE dns.zone SET version = $nversion, gen = 0
		    WHERE name = '$qzone'"
    if {! [::pgsql::execsql $dbfd $sql m]} then {
	set txt $m
	return 0
    }

    #
    # Generation successfull
    #

    return 1
}

#
# Return zone contents for a forward zone
#
# Input:
#   - dbfd: database handle
#   - zone: name of zone to generate
#   - selection: selection criterion (domain name)
#   - idview: view associated with this zone
#   - rrsup: RR to add to each generated name
#   - _txt: in return, zone contents or error message
# Output:
#   - return value: 1 if ok, 0 if error
#   - parameter _txt: zone contents or error message
#
# History:
#   2002/04/26 : pda/jean : design
#   2004/03/09 : pda/jean : add mail role generation
#   2012/10/24 : pda/jean : add views
#

proc gen-fwd {dbfd zone selection idview rrsup _txt} {
    upvar $_txt txt

    read-all-domains $dbfd "" tabiddom

    #
    # Get working domain id
    #
    set iddom -1
    set sql "SELECT iddom FROM dns.domain WHERE name = '$selection'"
    pg_select $dbfd $sql tab {
	set iddom $tab(iddom)
    }
    if {$iddom == -1} then {
	set txt "Zone $zone: domain '$selection' not found in database"
	return 0
    }

    #
    # Get all IP (v4 or v6) addresses
    #

    set sql "SELECT rr.name, rr.ttl, rr_ip.addr, family(rr_ip.addr) AS family
			FROM dns.rr, dns.rr_ip
			WHERE rr.iddom = $iddom
			    AND rr.idview = $idview
			    AND rr.idrr = rr_ip.idrr
			ORDER BY upper(rr.name), rr_ip.addr"
    pg_select $dbfd $sql tab {
	set name   $tab(name)
	set ttl    $tab(ttl)
	set family $tab(family)
	if {$family == 4} then {
	    set a "A"
	} else {
	    set a "AAAA"
	}
	if {$ttl == -1} then {
	    set ttl ""
	}
	append txt "$name	$ttl	IN	$a	$tab(addr)"
	append txt "\n"

	if {$rrsup ne "" && ! [info exists affiche($name)]} then {
	    set affiche($name) ""
	    set r $rrsup
	    regsub -all -- {%NAME%} $r $name r
	    append txt $r
	    append txt "\n"
	}
    }

    #
    # Get all MX: "a MX n b" (rr1 is a, rr2 is b)
    #

    set sql "SELECT rr1.name, rr1.ttl, rr_mx.prio,
			    rr2.name AS name2, rr2.iddom AS iddom2
			FROM dns.rr rr1, dns.rr_mx, dns.rr rr2
			WHERE rr1.iddom = $iddom
			    AND rr1.idrr = rr_mx.idrr
			    AND rr2.idrr = rr_mx.mx
			    AND rr1.idview = $idview
			ORDER BY upper(rr1.name)"
    pg_select $dbfd $sql tab {
	set name $tab(name)
	set ttl $tab(ttl)
	set d $tab(iddom2)
	set fqdn2 "$tab(name2).$tabiddom($d)."
	if {$ttl == -1} then {
	    set ttl ""
	}
	append txt "$name	$ttl	IN	MX	$tab(prio) $fqdn2"
	append txt "\n"
    }

    #
    # Get all aliases: "a CNAME b" (rr1 is a, rr2 is b)
    #

    set sql "SELECT rr1.name, rr1.ttl, rr2.name AS name2, rr2.iddom AS iddom2
			FROM dns.rr rr1, dns.rr_cname, dns.rr rr2
			WHERE rr1.iddom = $iddom
			    AND rr1.idrr = rr_cname.idrr
			    AND rr2.idrr = rr_cname.cname
			    AND rr1.idview = $idview
			ORDER BY upper(rr1.name)"
    pg_select $dbfd $sql tab {
	set d $tab(iddom2)
	set fqdn2 "$tab(name2).$tabiddom($d)."
	set ttl $tab(ttl)
	if {$ttl == -1} then {
	    set ttl ""
	}
	append txt "$tab(name)	$ttl	IN	CNAME	$fqdn2"
	append txt "\n"
    }

    #
    # Is there some mail relays for this domain?
    #

    set sql "SELECT relay_dom.prio,
			rr.name || '.' || domain.name || '.' AS rrname
		    FROM dns.relay_dom, dns.rr, dns.domain
		    WHERE relay_dom.iddom = $iddom
			AND relay_dom.mx = rr.idrr
			AND rr.iddom = domain.iddom
			AND rr.idview = $idview
		    ORDER BY relay_dom.prio ASC, domain.name, upper(rr.name)
		"
    set relays {}
    pg_select $dbfd $sql tab {
	lappend relays "IN	MX	$tab(prio) $tab(rrname)"
    }

    #
    # Get all mail roles
    #

    if {[llength $relays] > 0} then {
	set sql "SELECT rr.name, rr.ttl
			FROM dns.mail_role, dns.rr
			WHERE mail_role.mailaddr = rr.idrr
			    AND rr.idview = $idview
			    AND rr.iddom = $iddom
			ORDER BY upper(rr.name) ASC
			"
	pg_select $dbfd $sql tab {
	    foreach r $relays {
		set ttl $tab(ttl)
		if {$ttl == -1} then {
		    set ttl ""
		}
		append txt "$tab(name)	$ttl	$r"
		append txt "\n"
	    }
	}
    }

    #
    # Done!
    #

    return 1
}

#
# Return zone contents for a IPv4 reverse zone
#
# Input:
#   - dbfd: database handle
#   - zone: name of zone to generate
#   - selection: selection criterion (CIDR)
#   - idview: view associated with this zone
#   - rrsup: RR to add to each generated PTR address
#   - _txt: in return, zone contents or error message
# Output:
#   - return value: 1 if ok, 0 if error
#   - parameter _txt: zone contents or error message
#
# History:
#   2002/04/26 : pda/jean : design
#   2012/10/24 : pda/jean : add views
#

proc gen-ipv4 {dbfd zone selection idview rrsup _txt} {
    upvar $_txt txt

    read-all-domains $dbfd "" tabiddom

    #
    # Get CIDR prefix length to compute how many bytes we keep in RR name
    #

    if {! [regexp {.*/([0-9]*)} $selection bidon prefixlen]} then {
	set txt "zone '$zone' : invalid selection criterion ('$selection')"
	return 0
    }
    
    if {$prefixlen >= 24} then {
	set first 3
    } elseif {$prefixlen >= 16} then {
	set first 2
    } elseif {$prefixlen >= 8} then {
	set first 1
    }

    set sql "SELECT rr_ip.addr, rr.name, rr.ttl, rr.iddom
			FROM dns.rr_ip, dns.rr
			WHERE rr_ip.addr <<= '$selection'
			    AND rr.idview = $idview
			    AND rr_ip.idrr = rr.idrr
			ORDER BY rr_ip.addr"
    pg_select $dbfd $sql tab {
	#
	# Get PTR
	#

	set fqdn "$tab(name).$tabiddom($tab(iddom))."

	set addr $tab(addr)
	set lname {}
	foreach byte [lrange [split $addr "."] $first 3] {
	    set lname [linsert $lname 0 $byte]
	}
	set name [join $lname "."]

	set ttl $tab(ttl)
	if {$ttl == -1} then {
	    set ttl ""
	}
	append txt "$name	$ttl	IN	PTR	$fqdn"
	append txt "\n"
    }

    return 1
}

#
# Return zone contents for a IPv6 reverse zone
#
# Input:
#   - dbfd: database handle
#   - zone: name of zone to generate
#   - selection: selection criterion
#   - idview: view associated with this zone
#   - rrsup: RR to add to each generated PTR address
#   - _txt: in return, zone contents or error message
# Output:
#   - return value: 1 if ok, 0 if error
#   - parameter _txt: zone contents or error message
#
# History:
#   2002/04/26 : pda/jean : specification
#   2004/01/14 : pda/jean : design
#   2012/10/24 : pda/jean : add views
#

proc gen-ipv6 {dbfd zone selection idview rrsup _txt} {
    upvar $_txt txt

    read-all-domains $dbfd "" tabiddom

    #
    # Get prefix length to compute how many nibbles we keep in RR name
    #

    if {! [regexp {.*/([0-9]*)} $selection bidon prefixlen]} then {
	set txt "zone '$zone': invalid selection criterion ('$selection')"
	return 0
    }

    if {$prefixlen % 4 != 0} then {
	set txt "zone '$zone': prefix not multiple of 4 ('$selection')"
	return 0
    }
    
    set nbq [expr 32 - ($prefixlen / 4)]

    set sql "SELECT rr_ip.addr, rr.name, rr.ttl, rr.iddom
			FROM dns.rr_ip, dns.rr
			WHERE rr_ip.addr <<= '$selection'
			    AND rr.idview = $idview
			    AND rr_ip.idrr = rr.idrr
			ORDER BY rr_ip.addr"
    pg_select $dbfd $sql tab {
	#
	# Remove particular case where address contains "::" at the beginning
	# or at the end
	#

	regsub {^::} $tab(addr) {0::} addr
	regsub {::$} $addr {::0} addr

	#
	# IPv4 compatible IPv6 addresses (last part = a.b.c.d)
	#

	set l [split $addr ":"]

	set ip4 [split [lindex $l end] "."]
	if {[llength $ip4] == 4} then {
	    set l [lreplace $l end end]

	    set p1 [format "%x" [expr [lindex $ip4 0] * 256 + [lindex $ip4 1]]]
	    lappend l $p1

	    set p2 [format "%x" [expr [lindex $ip4 2] * 256 + [lindex $ip4 3]]]
	    lappend l $p2
	}

	#
	# If there is a "::" in address
	#

	set n [llength $l]
	set len0 [expr 8 - $n]
	set posempty [lsearch $l {}]
	if {$posempty >= 0} then {
	    set l [concat [lrange $l 0 [expr $posempty - 1]] \
			  [lrange {0 0 0 0 0 0 0 0} 0 $len0] \
			  [lrange $l [expr $posempty + 1] end] \
		      ]
	}

	#
	# Each list element should be a nibble. Reverse the list.
	#

	set nl {}
	foreach e $l {
	    foreach q [split [format "%04x" 0x$e] ""] {
		set nl [linsert $nl 0 $q]
	    }
	}

	#
	# Keep only first nbq nibbles
	#

	set name [join [lrange $nl 0 [expr $nbq - 1]] "."]

	#
	# Get out the PTR
	#

	set fqdn "$tab(name).$tabiddom($tab(iddom))."

	set ttl $tab(ttl)
	if {$ttl == -1} then {
	    set ttl ""
	}
	append txt "$name	$ttl	IN	PTR	$fqdn"
	append txt "\n"
    }

    return 1
}

##############################################################################
# main
##############################################################################

proc usage {argv0} {
    global conf

    regsub ".*/" $argv0 "" argv0
    puts -nonewline stderr [format $conf(usage) $argv0]
    exit 1
}

proc main {argv0 argv} {
    global conf

    #
    # Initialization : Netmagis database access and file queue
    #

    set msg [d init-script dbfd $argv0 true tabcor]
    if {$msg ne ""} then {
	puts stderr $msg
	return 1
    }

    set fq [::fileinst create %AUTO%]

    #
    # Argument checking
    #

    set verbose 0
    set doit 1
    set view ""

    while {[llength $argv] > 0} {
	set a [lindex $argv 0]
	switch -glob -- $a {
	    -h {
		usage $argv0
	    }
	    -q {
		set verbose -1
		set argv [lreplace $argv 0 0]
	    }
	    -v {
		set verbose 1
		set argv [lreplace $argv 0 0]
	    }
	    -n {
		set doit 0
		set argv [lreplace $argv 0 0]
	    }
	    -w {
		set view [lindex $argv 1]
		set argv [lreplace $argv 0 1]
	    }
	    -* {
		warning "Unknown option '$a'"
		usage $argv0
	    }
	    default {
		break
	    }
	}
    }

    #
    # View name is incompatible with zone names
    #

    if {$view ne "" && [llength $argv] > 0} then {
	usage $argv0
    }

    #
    # Get configuration values
    #

    foreach o {diff zonedir zonecmd} {
	set $o [get-local-conf $o]
    }

    #
    # Lock tables such as we do not miss some modification
    #

    set msg [d dblock {dns.zone_forward dns.zone_reverse4 dns.zone_reverse6}]
    if {$msg ne ""} then {
	d error $msg
    }

    #
    # Check view name
    #

    set idview -1
    if {$view ne ""} then {
	set qview [::pgsql::quote $view]
	set sql "SELECT idview FROM dns.view WHERE name = '$qview'"
	pg_select $dbfd $sql tab {
	    set idview $tab(idview)
	}
	if {$idview == -1} then {
	    d error "View '$view' not found"
	}
    }

    #
    # Use specific zones, or fetches only modified zones?
    #

    if {[llength $argv] == 0} then {
	set lz [get-mod-zones $dbfd $idview]
    } else {
	set lz $argv
    }

    #
    # Process zones
    #

    foreach z $lz {
	if {$verbose >= 0} then {
	    puts "Generating zone '$z'"
	}

	#
	# Generates zone contents
	#

	if {! [gen-zone $dbfd $z txt]} then {
	    set msg [d dbabort "zone generation" $txt]
	    d error $msg
	}

	set fname "$zonedir/$z"

	if {$verbose == 1} then {
	    show-diff-file-text stdout $diff "$fname" $txt
	}

	#
	# Add the modified file to the file queue
	#

	if {$doit} then {
	    set msg [$fq add "$fname" $txt]
	    if {$msg ne ""} then {
		set msg [d dbabort "zone generation" $msg]
		d error $msg
	    }
	}
    }

    #
    # Install files and run command
    #

    if {$doit} then {

	set msg [$fq commit]
	if {$msg ne ""} then {
	    set msg [d dbabort "zone generation" $msg]
	    d error $msg
	}

	if {$zonecmd ne ""} then {
	    if {[catch {exec -ignorestderr sh -c $zonecmd} msg]} then {
		set msg "Cannot run command '$zonecmd'\n$msg"
		set m [$fq uncommit]
		if {$m ne ""} then {
		    append msg "\n$m"
		}
		d error $msg
	    }
	}

	#
	# All is ok
	#

	set msg [d dbcommit "zone generation"]
	if {$msg ne ""} then {
	    set m [$fq uncommit]
	    if {$m ne ""} then {
		append msg "\n$m"
	    }
	    d error $msg
	}
    }

    $fq destroy

    d end
    return 0
}

exit [main $argv0 $argv]
