sauce 0.9.0+nmu3 / usr / share / sauce / dns

########### dns.tcl
# DNS lookup code, using `host'
#
# This file is part of SAUCE, a very picky anti-spam receiver-SMTP.
# SAUCE is Copyright (C) 1997-2003 Ian Jackson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 
#
# $Id: dns.tcl,v 1.20 2006/04/03 00:57:16 ian Exp $

########## dns threads
#
# thread_start dns $desc $domain $type $cnameok
#
# success => $answers {} OK
# permanent failure (domain unknown) => {} $emsgstr NXDOMAIN
# permanent failure (type unknown) => {} $emsgstr NOTYPE
# permanent failure (misconfigured) => {} $emsgstr MISCONFIG
# temporary failure =>X
# $emsgstr is always a single line

# global variables:
# adns                $adnsresid:$adnsresno
# adnsresid           the actual adns resolver handle
# dns_refcount($adns) how many outstanding queries, +1 if current resolver

# state variables:
# adns        $adns at query start
# adnsid      actual adns query handle
# emsgprefix  used for error message
# pdesc       used for debug0 trace

load chiark_tcl_adns-1.so

set rrdata_adnstype(MX) mx
set rrdata_adnstype(A) a
set rrdata_adnstype(TXT) txt
set rrdata_adnstype(PTR) ptr-

if {![info exists adnsresno]} { set adnsresno 0 }

proc dns_deref {adns} {
    upvar #0 dns_refcount($adns) refcount
    if {[incr refcount -1] > 0} return
    debug0 1 "adns $adns all-done"
    adns destroy-resolver [lindex [split $adns :] 0]
}

proc dns_readconfig {} {
    global adns
    if {[info exists adns]} {
	dns_deref $adns
	unset adns
    }
}

proc dns__errcallback {msg} {
    log error $msg
}

thread_typedefine dns {domain type cnameok} {
    global adns adnsresid adnsresno adns_options var_dir rrdata_adnstype

    if {![info exists adns]} {
	set adnsresid [eval \
		[list adns new-resolver -errcallback dns__errcallback] \
		[split $adns_options]]
	incr adnsresno
	set adns [list $adnsresid:$adnsresno]
	upvar #0 dns_refcount($adns) refcount
	set refcount 1
	debug0 1 "adns $adns started"
    } else {
	upvar #0 dns_refcount($adns) refcount
    }

    set domain [string tolower $domain]
    set adnsopts [list -resolver $adnsresid]

    set state(emsgprefix) "Error during DNS $type lookup for $domain"
    set state(adns) $adns
    
    if {$cnameok} {
	set cnokstr "~"
    } else {
	set cnokstr "!"
	lappend adnsopts -cname-forbid
    }
    set state(pdesc) "$state(desc) / $adns $domain $type$cnokstr"

    set state(adnsid) [eval \
	    [list adns asynch dns_yes dns_no dns_no $id \
	          $rrdata_adnstype($type) $domain] \
	    $adnsopts]
    incr refcount
    return $id
} ERROR-ON-SHUTDOWN {
    catch { adns asynch-cancel $state(adnsid) }
}

proc dns_yes {id args} { eval thread_crosscall dns $id yes $args }
proc dns_no {id args} { eval thread_crosscall dns $id no $args }

thread_chainproc dns yes {etype ecode ename estring owner cname rrset} {
    unset state(adnsid)
    debug0 1 "$state(pdesc) => OK $rrset"
    dns_deref $state(adns)
    thread_finish dns $id $rrset {} OK
}

thread_chainproc dns no {etype ecode ename estring owner cname rrset} {
    unset state(adnsid)
    set emsgstr "$state(emsgprefix): $estring"
    debug0 1 "$state(pdesc) !> $ecode $ename $estring"
    dns_deref $state(adns)
    if {$ecode <= 99} {
	thread_error dns $id $emsgstr {}
    } elseif {$ecode <= 199} {
	thread_finish dns $id {} $emsgstr MISCONFIG
    } elseif {$ecode <= 299 || ![string compare $ename nxdomain]} {
	thread_finish dns $id {} $emsgstr NXDOMAIN
    } elseif {![string compare $ename nodata]} {
	thread_finish dns $id {} $emsgstr NOTYPE
    } else {
	error "Internal error: unexpected status: $ecode $ename"
    }
}

########## dnsptr threads
#
# thread_start dnsptr $desc $ipaddr
#
# success => $ipaddr {}
# permanent failure => {} $error
# temporary failure =>X
# $error is a single line string

# state variables:
# ipaddr    address for which PTR is requested
# dnsid     id of DNS query subthread (unset => none)
# remain    list of unchecked returns from PTR in-addr lookup (unset until DNS finishes)
# errs      list of hard error message(s)

thread_typedefine dnsptr {ipaddr} {
    set state(ipaddr) $ipaddr
    set ptr in-addr.arpa
    foreach octet [split $ipaddr .] {
	set ptr $octet.$ptr
    }
    set state(dnsid) [thread_start dns $state(desc) $ptr PTR 1]
    thread_join dnsptr $id dns $state(dnsid) dns_rvok dns_rverr
} ERROR-ON-SHUTDOWN {
    catch { thread_cancel $state(dnsid) }
}

thread_chainproc dnsptr dns_rvok {answers emsgstr how} {
    unset state(dnsid)
    if {[llength $answers]} {
	set state(remain) $answers
	set state(errs) {}
	dnsptr_continue
    } else {
	thread_finish dnsptr $id {} $emsgstr
    }
}

thread_chainproc dnsptr dns_rverr {emsg} {
    unset state(dnsid)
    thread_error dnsptr $id $emsg {}
}

thread_subproc dnsptr continue {} {
    if {![llength $state(remain)]} {
	thread_finish dnsptr $id {} \
		"$state(ipaddr) -> [join $state(errs) {; }]"
	return
    }
    set remain $state(remain)
    set try [lindex $remain 0]
    set state(remain) [lreplace $remain 0 0]
    set state(dnsid) [thread_start dns $state(desc) $try A 0]
    thread_join dnsptr $id dns $state(dnsid) dns_fwok dns_fwerr $try
}

thread_chainproc dnsptr dns_fwok {try answers emsgstr how} {
    unset state(dnsid)
    if {![string length $answers]} {
	lappend state(errs) "$try -> $emsgstr"
    } else {
	foreach ans $answers {
	    if {"$ans"=="$state(ipaddr)"} {
		thread_finish dnsptr $id $try {}
		return
	    }
	}
	lappend state(errs) "$try -> [join $answers {, }]"
    }
    dnsptr_continue
}

thread_chainproc dnsptr dns_fwerr {try emsg} {
    unset state(dnsid)
    thread_error dnsptr $id "$try -> $emsg" {}
}