#!%TCLSH%


#
# Script pour chercher le ou les correspondants associs  un
# rseau,  une adresse IP ou une machine.
#
# Appel par : index.htgt
#
# Paramtres (formulaire ou URL) :
#	- critere : critere de recherche (ip, cidr, ou fqdn, ou _ pour ici)
#
# Historique
#   2002/07/25 : pda      : cration
#   2003/05/13 : pda/jean : utilisation de la base d'authentification
#   2004/01/14 : pda/jean : ajout IPv6
#   2004/08/06 : pda/jean : extension des droits sur les rseaux
#   2005/02/24 : pda      : ajout cas rle mail sans adresse IP
#   2010/10/17 : pda      : ajout recherche "o suis-je"
#

set conf(homeurl)	%HOMEURL%

#
# Chemins utiliss par les scripts
#

set conf(pkg)		%PKGTCL%
set conf(lib)		%DESTDIR%/lib
set conf(libdns)	$conf(lib)/libdns.tcl

#
# Dfinition des noms des pages " trous"
#

set conf(err)		$conf(lib)/erreur.html
set conf(page)		$conf(lib)/corresp.html

#
# Quelques paramtres du script
#

set conf(auth)		%AUTH%
set conf(base)		%BASE%
set conf(nologin)	%NOLOGIN%
set conf(log)		%LOG%

set conf(form)	{
	{critere	0 1 {}}
	{ousuisje	0 1 {}}
}

#
# Tableau pour afficher une machine
#



#
# Les outils du parfait concepteur de pages Web dynamiques...
#

lappend auto_path $conf(pkg)
package require webapp
package require pgsql
package require arrgen

#
# On y va !
#

# ::webapp::cgidebug ; exit

source $conf(libdns)

proc corresp-erreur {critere msg} {
    global conf

    set qmsg     [::webapp::html-string $msg]
    set qcritere [::webapp::unpost-string $critere]
    set resultat "<FONT COLOR=\"FF0000\">$qmsg</FONT>"
    ::webapp::send html [::webapp::file-subst $conf(page) \
			    [list \
				    [list %CRITERE% $qcritere] \
				    [list %RESULTAT% $resultat] \
				] \
			    ]
    exit 0
}

##############################################################################
# Programme principal
##############################################################################

proc main {} {
    global conf

    #
    # Initialisation
    #

    init-dns $conf(nologin) $conf(auth) $conf(base) $conf(err) {} \
		$conf(form) ftab dbfd login tabcor $conf(log)

    set critere [string trim [lindex $ftab(critere) 0]]

    #
    # Est-ce que c'est une adresse IP ?
    #

    if {[string equal $critere ""]} then {
	#
	# Rien. Ce n'est pas une erreur  strictement parler,
	# mais on le traite comme tel.
	#
	corresp-erreur "" ""

    } elseif {[string equal $critere "_"]} then {
	global env

	if {[info exists env(REMOTE_ADDR)]} then {
	    set adr $env(REMOTE_ADDR)
	    set critere $adr
	    lire-rr-par-ip $dbfd $adr tabrr
	} else {
	    corresp-erreur "" ""
	}
    } elseif {[string equal [syntaxe-ip $dbfd $critere "inet"] ""]} then {
	#
	# Adresse IP
	#
	set adr $critere

	#
	# Tentative de recherche de la machine. Si elle existe,
	# tabrr sera rempli. Si non, tabrr ne sera pas cr.
	# On ne se proccupe pas du rsultat (l'existence ou non
	# de tabrr(idrr) nous suffira) par la suite.
	#
	lire-rr-par-ip $dbfd $critere tabrr

    } elseif {[string equal [syntaxe-ip $dbfd $critere "cidr"] ""]} then {
	#
	# CIDR
	#
	set adr $critere

    } elseif {[regexp {^([^.]+)\.(.+)$} $critere bidon nom domaine]} then {
	#
	# Nom et domaine
	#
	set iddom [lire-domaine $dbfd $domaine]
	if {$iddom == -1} then {
	    corresp-erreur $critere "Domaine '$domaine' non trouv."
	}

	if {! [lire-rr-par-nom $dbfd $nom $iddom tabrr]} then {
	    corresp-erreur $critere \
		"Machine '$nom' non trouve dans le domaine '$domaine'."
	}

    } elseif {[regexp {^([^.]+)$}  $critere bidon nom]} then {
	#
	# Nom sans domaine : prendre par dfaut le domaine privilgi
	# du correspondant qui excute ce script.
	#
	set qnom [::pgsql::quote $nom]
	set idrr -1
	set iddom -1
	set sql "SELECT d.iddom, d.nom
			FROM corresp c, groupe g, dr_dom dd, domaine d
			WHERE c.idcor = $tabcor(idcor)
			    AND c.idgrp = g.idgrp
			    AND g.idgrp = dd.idgrp
			    AND dd.iddom = d.iddom
			ORDER BY dd.tri ASC
			LIMIT 1
			"
	pg_select $dbfd $sql tab {
	    set iddom $tab(iddom)
	    set domaine $tab(nom)
	}
	if {$iddom == -1} then {
	    ::webapp::error-exit $conf(err) "Pas de domaine par dfaut !"
	}
	if {! [lire-rr-par-nom $dbfd $nom $iddom tabrr]} then {
	    corresp-erreur $critere \
		"Machine '$nom' non trouve dans le domaine '$domaine'."
	}

    } else {
	#
	# On ne peut normalement pas arriver l : tout doit passer
	# dans le cas prcdent !
	#
	corresp-erreur $critere "Critre de recherche '$critere' invalide."
    }

    #
    # Si on arrive ici, c'est qu'on a russi  analyser le
    # critre de recherche.
    #
    # Si, de plus, tabrr(idrr) existe, c'est que le nom ou l'adresse
    # correspond  une machine relle.
    #

    #
    # Si c'est un alias, rechercher la vraie adresse
    #

    if {[info exists tabrr(cname)]} then {
	if {! [string equal $tabrr(cname) ""]} then {
	    set idrr $tabrr(cname)
	    unset tabrr
	    if {! [lire-rr-par-id $dbfd $idrr tabrr]} then {
		::webapp::error-exit $conf(err) \
			"Erreur interne : objet point par l'alias non trouv"
	    }
	}
    }

    #
    # Si c'est un rle de messagerie, sans adresse IP, rechercher
    # l'adresse de l'hbergeur.
    #

    if {[info exists tabrr(rolemail)] && [llength $tabrr(ip)] == 0} then {
	if {! [string equal $tabrr(rolemail) ""]} then {
	    set idrr $tabrr(rolemail)
	    unset tabrr
	    if {! [lire-rr-par-id $dbfd $idrr tabrr]} then {
		::webapp::error-exit $conf(err) \
			"Erreur interne : hbergeur du rolemail non trouv"
	    }
	}
    }

    #
    # Si le critre tait un nom et pas une adresse IP, extraire une
    # adresse IP (au hasard parmi celles associes au nom).
    #

    if {! [info exists adr]} then {
	if {! [info exists tabrr(ip)]} then {
	    ::webapp::error-exit $conf(err) "Erreur interne : pas d'adresse et pas de tabrr"
	}

	set adr [lindex $tabrr(ip) 0]
    }

    #
    # Afficher l'adresse
    #

    set resultat ""

    append resultat "Adresse recherche&nbsp;: $adr\n"
    append resultat "<P>\n"

    #
    # Si on a trouv une machine  cette adresse, afficher les
    # informations pertinentes
    #

    if {[info exists tabrr(idrr)]} then {
	append resultat [presenter-rr $dbfd -1 tabrr]
	append resultat "<P>"
    }

    #
    # Rechercher les diffrents correspondants qui peuvent
    # potentiellement s'occuper de la plage dans laquelle
    # il y a cette adresse.
    #

    set sql "SELECT c.idcor
		    FROM corresp c, groupe g, dr_reseau d, reseau r
		    WHERE c.idgrp = g.idgrp
			AND g.idgrp = d.idgrp
			AND d.idreseau = r.idreseau
			AND ('$adr' <<= r.adr4 OR '$adr' <<= r.adr6)
			ORDER BY g.admin, g.nom
			"
    set lidcor {}
    pg_select $dbfd $sql tab {
	lappend lidcor $tab(idcor)
    }

    #
    # Parmi les correspondants slectionns, rechercher ceux
    # dont les droits correspondent  l'adresse fournie.
    #

    set trouve 0
    foreach idcor $lidcor {
	if {[droit-correspondant-ip $dbfd $idcor $adr]} then {
	    set msg [lire-correspondant-par-id $dbfd $idcor tabcor]
	    if {! [string equal $msg ""]} then {
		::webapp::error-exit $conf(err) "Erreur interne ($msg)"
	    }
	    append resultat [html-correspondant tabcor]
	    append resultat "\n<P>\n"
	    set trouve 1
	}
    }

    #
    # Sortie du rsultat
    #

    ::webapp::send html [::webapp::file-subst $conf(page) \
		    [list \
			    [list %CRITERE% $critere] \
			    [list %RESULTAT% $resultat] \
			] \
	    ]

    #
    # Dconnexion de la base
    #

    fermer-base $dbfd
}

::webapp::cgi-exec main %DEBUG%
