# inet.tcl --
#
# This file contains some useful procedures that allow to use various
# TCP/IP network services.
#
# Copyright (c) 1996-1997 University of Twente.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require Tnm
package provide TnmInet $tnm(version)

# Tnm_InetDayTime --
#
# Retrieve the time of the day of a remote host.
#
# Arguments:
# host -	The target host that should be queried.

proc Tnm_InetDayTime {{host localhost}} {
    set s [socket $host daytime]
    fconfigure $s -translation crlf
    set code [catch {gets $s txt} msg]
    close $s
    if $code { error $msg }
    string trim $txt \n
}

# Tnm_InetFinger --
#
# Finger a host or a user on a host using the finger user information
# protocol (RFC 1288).
#
# Arguments:
# host -	The target host that should be finger'ed.
# user -	The name of the user from whom you want to get information.

proc Tnm_InetFinger {{host {localhost}} {user {}}} {
    set s [socket $host finger]
    fconfigure $s -translation crlf
    set txt ""
    set code [catch {
	puts $s $user; flush $s
	while {! [eof $s]} { append txt "[gets $s]\n" }
    } msg]
    close $s
    if $code { error $msg }
    string trim $txt \n
}

# Tnm_InetTraceRoute --
#
# Trace a route to a remote host. This is based on the classic van 
# Jacobsen traceroute algorithm.
#
# Arguments:
# host --	The target host that should be traced.

proc Tnm_InetTraceRoute {{host localhost} {maxlength 32} {retries 3}} {
    if {[regexp "^\[0-9\]+\.\[0-9\]+\.\[0-9\]+\.\[0-9\]+$" $host]} {
	set dst $host
    } elseif {[catch {netdb hosts address $host} dst]} {
	set dst [dns address $host]
    }
    for {set i 0} {$i < $retries} {incr i} { 
	lappend icmparg $dst
    }
    set l ""
    for {set ttl 1} {[lsearch $l $dst] < 0 && $ttl < $maxlength} {incr ttl} {
        set trace [icmp -retries 0 trace $ttl $icmparg]
        set l ""
        set time ""
        foreach {ip rtt} $trace {
            if {[string length $rtt]} {
                if {[lsearch $l $ip] < 0} { lappend l $ip }
                append time [format " %5d ms" $rtt]
            } else {
                append time "   *** ms"
            }
        }
	set names ""
        foreach ip $l {
            if {[catch {netdb hosts name $ip} name]} {
                if {[catch {dns name $ip} name]} {
                    set name $ip
                }
            }
            if {[lsearch $names $name] < 0} { lappend names $name }
        }
        append txt [format "%2d %-47s %s\n" \
		$ttl [string range $names 0 46] $time]
    }
    string trim $txt \n
}

# Tnm_InetTcpServices --
#
# Test the TCP services listed in the netdb services database by connecting
# to the various ports listed there. This does not really tell us, if we 
# could actually use a service but it is a hint.
#
# Arguments:
# host -	The target host that should be checked.

proc Tnm_InetTcpServices {{host localhost}} {
    set txt ""
    set services "X11 6000"
    foreach {name port protocol} [join [netdb services]] {
	if {[string compare $protocol tcp] == 0} {
	    lappend services $name $port
	}
    }
    foreach {name port} $services {
	if {[catch {socket $host $port} s]} {
	    continue
	}
	close $s
	append txt [format "  %-12s %6s/tcp\n" $name $port]
    }
    string trim $txt \n
}

# Tnm_InetRpcServices --
#
# Test the RPC services registered by the portmapper by calling their
# NULL procedure.
#
# Arguments:
# host -	The target host that should be checked.

proc Tnm_InetRpcServices {{host localhost}} {
    set txt ""
    set server [sunrpc info $host]
    foreach probe [lsort -ascii $server] {
	set probe [eval format "{%10s %2d %s %5d %-16s}" $probe]
	if {[catch {eval sunrpc probe $host $probe} res]} {
	    append txt "$probe\n"
	} else {
	    append txt [format "%s %6d ms %s\n" $probe [lindex $res 0] \
		    [string tolower [lindex $res 1]] ]
	}
    }
    string trim $txt \n
}

# Tnm_InetMail --
#
# Send a mail message to a list of recipients. Uses the SMTP protocol
# (RFC 821) to deliver the mail message to the next SMTP MTA.
#
# Arguments:
# recipients -	The list of recipients.
# msg -		The mail message.
# subject -	The optional subject of the message.

proc Tnm_InetMail {recipients msg {subject {}}} {
    global tnm

    if ![info exists tnm(email)] {
	set tnm(email) "$tnm(user)@$tnm(domain)"
    }
    if [catch {socket $tnm(host) smtp} s] {
	if [catch {dns mx $tnm(domain)} mxhosts] {
	    error "no smtp gateway found"
	}
	set tnm(email) "$tnm(user)@$tnm(domain)"
	foreach {h p} [join $mxhosts] {
	    lappend l [list $p $h]
	}
	foreach {priority host} [join [lsort $l]] {
	    if [catch {socket $host smtp} s] {
		continue
	    }
	    break
	}
    }
    if [catch {fconfigure $s -translation crlf}] {
	error "no smtp gateway found"
    }
    fconfigure $s -blocking true -buffering line

    TnmInetExpect $s 220
    puts $s "HELO $tnm(host).$tnm(domain)"
    TnmInetExpect $s 250
    puts $s "MAIL FROM:<$tnm(email)>"
    TnmInetExpect $s 250
    foreach r $recipients {
	puts $s "RCPT TO:<$r>"
	TnmInetExpect $s 250
    }
    puts $s "DATA"
    TnmInetExpect $s 354
    puts $s "To: [join $recipients ,]"
    if {[string length $subject]} {
	puts $s "Subject: $subject"
    }
    puts $s $msg
    puts $s "."
    TnmInetExpect $s 250
    close $s
}

# TnmInetExpect --
#
# This is a utility to read from a stream until a RFC 821 response
# has been recceived.
#
# Arguments:
# c -		The channel to read from.
# code -	The expected response code.

proc TnmInetExpect {c code} {
    while 1 {
	set n [gets $c line]
	if {$n < 0} { error "error while reading from $c" }
	if [string match {[0-9][0-9][0-9] *} $line] break
    }
    if ![string match "$code*" $line] {
	close $s
	error $line
    }
}