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


#
# Remplit les roles de messagerie  partir d'un fichier rolemail.txt
# sous la forme :
#	adresse-de-messagerie		[ relais ]
# L'adresse-de-messagerie est le nom du rle  crer, et
# le relais (optionnel) est le nom de l'hbergeur.
# Si l'hbergeur n'est pas fourni, il est initialis  l'adresse de
# messagerie (cas d'une machine devant recevoir son propre courrier).
# Si l'hbergeur est fourni, il devient galement son propre rle
# de messagerie.
#
# Exemple :
#	hemato-ulp.u-strasbg.fr		sokaris.u-strasbg.fr
#	adm-ulp.u-strasbg.fr		adm-ulp-mail.u-strasbg.fr
#	newb6.u-strasbg.fr
#
# Rsultats :
#	hmato-ulp   est un rle mail vers sokaris
#	sokaris      est un rle mail vers sokaris
#       adm-ulp      est un rle mail vers adm-ulp-mail
#       adm-ulp-mail est un rle mail vers adm-ulp-mail
#	newb6        est un rle mail vers newb6
#
# Remplit galement les relais de messagerie associs aux domaines
# et valide les droits pour tous les groupes ayant accs  ces domaines.
# Format du fichier relaisdom.txt :
#	domaine		priorit relais priorit relais ...
# Le couple <priorit, relais> est ajout comme relais pour chaque
# domaine cit.
#
# Usage :
#	<script> <rolemail.txt> <relaisdom.txt> <login>
#
# Historique
#   2004/03/04 : pda/jean : conception
#   2004/04/12 : pda      : ajout de relaisdom.txt
#   2005/04/08 : pda      : apdatation au nouveau format de base
#

#
# Valeurs par dfaut du script
#

set conf(base)		{dbname=dns user=dns password=mot-de-passe-de-dns}

package require Pgtcl


#
# Neutralise les caractres spciaux figurant dans une chane,
# de faon  pouvoir la passer au moteur SQL.
# - double toutes les apostrophes
#
#   - paramtres
#	- chaine : chane  traiter
#	- maxindex (optionnel) : taille maximum de la chane
# Sortie :
#   - valeur de retour : la chane traite
#
# Historique
#   1999/07/14 : pda : conception et codage
#   1999/10/24 : pda : mise en package
#

proc quote {chaine {maxindex 99999}} {
    set chaine [string range $chaine 0 $maxindex]
    regsub -all {'} $chaine {&&} chaine
    regsub -all {\\} $chaine {&&} chaine
    return $chaine
}

#
# Excute une commande sql, et affiche une erreur et sort
# en cas de problme. Retourne le rsultat de la commande
# (rsultat pour pg_result).
#
# Entre :
#   - paramtres
#	- dbfd : la base
#	- cmd : la commande  passer
#	- result : contient en retour le nom de la variable contenant l'erreur
# Sortie :
#   - valeur de retour : 1 si tout est ok, 0 sinon
#   - variable result :
#	- si erreur, la variable contient le message d'erreur
#
# Historique
#   1999/07/14 : pda : conception et codage
#   1999/10/24 : pda : mise en package
#

proc execsql {dbfd cmd result} {
    upvar $result rmsg

#  puts stderr "EXECSQL : $cmd"
    set res [pg_exec $dbfd $cmd]
    if {! [string equal [pg_result $res -status] PGRES_COMMAND_OK]} then {
	set ok 0
	set rmsg "$cmd : [pg_result $res -error]"
    } else {
	set ok 1
	set rmsg {}
    }
    pg_result $res -clear
    return $ok
}

proc erreur {msg} {
    warning $msg
    exit 1
}

proc warning {msg} {
    global argv0 fichier numligne
    if {$numligne == 0} then {
	puts stderr "$argv0: $msg"
    } else {
	puts stderr "$argv0: $fichier\[$numligne\] $msg"
    }
}

# lire depuis la base tous les noms de machines, et initialiser
# le tableau tabmach(fqdn) = idrr

proc lire-machines {dbfd} {
    global tabmach

    set sql "SELECT rr.nom || '.' || domaine.nom AS nom, rr.idrr
			FROM rr, domaine, rr_ip
			WHERE rr.idrr = rr_ip.idrr
			    AND rr.iddom = domaine.iddom
			GROUP BY rr.nom, domaine.nom, rr.idrr
			"
    catch {unset tabmach}
    pg_select $dbfd $sql tab {
	set nom  [string tolower $tab(nom)]
	set tabmach($nom) $tab(idrr)
    }
    return 1
}


# lire depuis la base tous les noms ne correspondant pas une machine
# et initialiser le tableau tabother(fqdn) = idrr

proc lire-autres-rr {dbfd} {
    global tabother

    set sql "SELECT rr.nom || '.' || domaine.nom AS nom, rr.idrr
			FROM rr, domaine
			WHERE rr.idrr NOT IN (SELECT idrr FROM rr_ip)
			    AND rr.iddom = domaine.iddom
			GROUP BY rr.nom, domaine.nom, rr.idrr
			"
    catch {unset tabother}
    pg_select $dbfd $sql tab {
	set nom  [string tolower $tab(nom)]
	set tabother($nom) $tab(idrr)
    }
    return 1
}

# lire depuis la base tous les alias et initialiser le tableau
# tabother(fqdn) = idrrp (idrr du RR point)

proc lire-alias {dbfd} {
    global tabalias

    set sql "SELECT r1.nom || '.' || d1.nom AS nom1,
		    rr_cname.cname AS cname,
		    r2.nom || '.' || d2.nom AS nom2
		FROM rr r1, domaine d1, rr_cname, rr r2, domaine d2
		WHERE r1.idrr = rr_cname.idrr
		    AND r1.iddom = d1.iddom
		    AND rr_cname.cname = r2.idrr
		    AND r2.iddom = d2.iddom
		"
    catch {unset tabalias}
    pg_select $dbfd $sql tab {
	set nom1  [string tolower $tab(nom1)]
	set nom2  [string tolower $tab(nom2)]
	set tabalias($nom1) [list $tab(cname) $nom2]
    }
    return 1
}


# lire depuis la base tous les rles de messagerie existants et
# initialiser le tableau tabrole(fqdn) = fqdn de l'hbergeur

proc lire-rolemail {dbfd} {
    global tabrole

    set sql "SELECT r1.nom || '.' || d1.nom AS nom,
			r2.nom || '.' || d2.nom AS nomh,
			r2.idrr AS idrrh
		    FROM role_mail, rr r1, domaine d1, rr r2, domaine d2
		    WHERE role_mail.idrr = r1.idrr AND r1.iddom = d1.iddom
			AND role_mail.heberg = r2.idrr AND r2.iddom = d2.iddom
			"
    catch {unset tabrole}
    pg_select $dbfd $sql tab {
	set nom  [string tolower $tab(nom)]
	set nomh [string tolower $tab(nomh)]
	set tabrole($nom) [list $nomh $tab(idrrh)]
    }
    return 1
}


# lire depuis la base tous les identificateurs de domaines                       
# et initialiser le tableau tabdom(domaine) = iddom

proc lire-domaine {dbfd} {
    global tabdom

    set sql "SELECT iddom, nom FROM domaine"
    catch {unset tabdom}
    pg_select $dbfd $sql tab {
	set nom  [string tolower $tab(nom)]
	set tabdom($nom) $tab(iddom)
    }
    return 1
}


proc remplir-rolemail {dbfd idcor fd} {
    global tabmach tabother tabrole tabdom
    global numligne

    set r 1
    set numligne 0
    while {[gets $fd ligne] > -1} {
	incr numligne
	regsub -all {#.*} $ligne {} ligne
	set p1 [lindex $ligne 0]
	set p2 [lindex $ligne 1]
	switch [llength $ligne] {
	    0 {
		# rien
	    }
	    1 {
		if {! [ajouter-rolemail $dbfd $idcor $p1 $p1]} then {
		    set r 0
		}
	    }
	    2 {
		if {! [ajouter-rolemail $dbfd $idcor $p1 $p2]} then {
		    set r 0
		}
	    }
	    default {
		warning "Syntaxe incorrecte"
		set r 0
	    }
	}
    }
    return $r
}

proc syntaxe-nom {nom} {
    # cas gnral : une lettre-ou-chiffre en dbut, une lettre-ou-chiffre
    #  la fin (tiret interdit en fin) et lettre-ou-chiffre-ou-tiret au
    # milieu
    set re1 {[a-zA-Z0-9][-a-zA-Z0-9]*[a-zA-Z0-9]}
    # cas particulier d'une seule lettre
    set re2 {[a-zA-Z0-9]}

    if {[regexp "^$re1$" $nom] || [regexp "^$re2$" $nom]} then {
	set m ""
    } else {
	set m "Syntaxe invalide"
    }

    return $m
}

#
# Cre un nouveau nom
#
proc nouveau-rr {dbfd nom iddom idcor} {
    set sql "INSERT INTO rr (nom, iddom, \
    		idhinfo, commentaire, respnom, respmel, \
    		idcor) \
    	    VALUES ('$nom', $iddom, \
    		0, '', '', '', \
    		$idcor)"
    if {! [execsql $dbfd $sql m]} then { warning $m ; return 0}
    
    # recuperation de l'id insr
    set sql "SELECT idrr FROM rr WHERE nom = '$nom' AND iddom = $iddom"
    pg_select $dbfd $sql tab {
        set idrr $tab(idrr)
    }
    if {! [info exists idrr]} then {
        return ""
    }
    return $idrr
}

proc separer-fqdn {fqdn tabdomvar nomvar iddomvar} {
    upvar $tabdomvar tabdom
    upvar $nomvar nom
    upvar $iddomvar iddom

    if {! [regexp {^([^.]+)\.(.+)} $fqdn bidon nom domaine]} then {
	warning "Syntaxe invalide ($fqdn)"
	return 0
    }

    set msg [syntaxe-nom $nom]
    if {! [string equal $msg ""]} then {
	warning "Syntaxe invalide pour le premier constituant '$nom' de '$fqdn'"
	return 0
    }

    set domaine [string tolower $domaine]
    if {! [info exists tabdom($domaine)]} then {
	warning "Domaine '$domaine' inexistant pour $fqdn"
	return 0
    }
    set iddom $tabdom($domaine)

    return 1
}

proc ajouter-rolemail {dbfd idcor fqdn fqdnh} {
    global tabmach tabother tabrole tabdom tabalias

#  puts stderr "ajouter-rolemail $fqdn -> $fqdnh"
    #
    # Sparer les constituants
    #

    if {! [separer-fqdn $fqdn tabdom nom iddom]} then {
	return 0
    }
    if {! [separer-fqdn $fqdnh tabdom nomh iddomh]} then {
	return 0
    }

    #
    # Recherche l'idrr ou cre le RR si ncessaire
    #
    set idrr ""
    if {[info exists tabalias($fqdn)]} then {
	set idrr [lindex $tabalias($fqdn) 0]
	set fqdn [lindex $tabalias($fqdn) 1]
    } else {
	if {[info exists tabmach($fqdn)]} then {
	    set idrr $tabmach($fqdn)
	} else {
	    if {[info exists tabother($fqdn)] } then {
		set idrr $tabother($fqdn)
	    } else {
		set idrr [nouveau-rr $dbfd $nom $iddom $idcor]
		if {[string equal $idrr ""]} then {
		    warning "$fqdn : cration impossible"
		    return 0
		} else {
		    set tabother($fqdn) $idrr
		}
	    }
	}
    }
    if {[string equal $idrr ""]} then {
	warning "$fqdn : rr inexistant"
	return 0
    }
    
    #
    # Recherche l'hebergeur
    #

    if {[info exists tabmach($fqdnh)]} then {
	set idrrh $tabmach($fqdnh)
    } else {
	if {[info exists tabalias($fqdnh)]} then {
	    set idrrh [lindex $tabalias($fqdnh) 0]
	} else {
	    warning "Hbergeur '$fqdnh' non trouv pour le rle '$fqdn'"
	    return 0
	}
    }


    if {[info exists tabrole($fqdn)]} then {
	#
	# Le rle mail existe dj. S'il est diffrent, on l'actualise
	# (et on le signale  l'utilisateur). Si c'est le mme, on
	# ne fait rien (et en silence).  

	if {! [string equal [lindex $tabrole($fqdn) 1] "$idrrh"] } then {

	    warning "Changement d'hbergeur pour le rle '$fqdn' ([lindex $tabrole($fqdn) 0] -> $fqdnh)"

	    set sql "UPDATE role_mail SET heberg = $idrrh WHERE idrr = $idrr"
	    if {! [execsql $dbfd $sql m]} then { warning $m ; return 0 }

	} else {
	    # Rien
	}

    } else {
	# Le rle n'existe pas. On le cre.
	set sql "INSERT INTO role_mail (idrr,heberg) VALUES ($idrr,$idrrh)"
	if {! [execsql $dbfd $sql m]} then { warning $m ; return 0 }
    }

    # Mise--jour de tabrole
    set tabrole($fqdn) [list "$fqdnh" "$idrrh"]

    return 1
}

proc remplir-relaisdom {dbfd fd} {
    global tabmach tabdom
    global numligne

    set r 1
    set numligne 0
    while {[gets $fd ligne] > -1} {
	incr numligne
	regsub -all {#.*} $ligne {} ligne
	set n [llength $ligne]
	if {$n > 0} then {
	    set dom [lindex $ligne 0]
	    if {! [info exists tabdom($dom)]} then {
		warning "Domaine '$dom' non trouv"
		continue
	    }
	    set iddom $tabdom($dom)
	    set ligne [lreplace $ligne 0 0]

	    #
	    # Actualise les droits pour tous les groupes ayant
	    # accs  ce domaine
	    #

	    set sql "UPDATE dr_dom SET rolemail = 1 WHERE iddom = $iddom"
	    if {! [execsql $dbfd $sql m]} then {
		warning $m
		set r 0
		continue
	    }

	    if {$n % 2 != 1} then {
		warning "Nb de couples invalides pour le domaine '$dom'"
		set r 0
		continue
	    }
	    set n [expr (($n - 1) / 2)]

	    #
	    # Met  jour la liste des relais pour ce domaine
	    #

	    for {set i 0} {$i < $n} {incr i} {
		set prio [lindex $ligne 0]
		set rel  [lindex $ligne 1]
		set ligne [lreplace $ligne 0 1]

		if {! [regexp {^[0-9]+$} $prio]} then {
		    warning "Priorit invalide ($prio) pour le relais '$rel'"
		    set r 0
		    continue
		}
		if {! [info exists tabmach($rel)]} then {
		    warning "Relais '$rel' non trouv"
		    set r 0
		    continue
		}
		set idrr $tabmach($rel)

		set sql "INSERT INTO relais_dom (iddom, priorite, mx)
				VALUES ($iddom, $prio, $idrr)"
		if {! [execsql $dbfd $sql m]} then {
		    warning $m
		    set r 0
		    continue
		}
	    }
	}
    }
    return $r
}


proc main {argv0 argv} {
    global conf
    global fichier numligne

    set fichier "(null)"
    set numligne 0

    if {[llength $argv] != 3} then {
	erreur "usage: $argv0 <rolemail.txt> <relaisdom.txt> <login>"
    }

    if {[catch {set dbfd [pg_connect -conninfo $conf(base)]} msg]} then {
	erreur "$argv0: cannot access base ($msg)"
    }

    set login [lindex $argv 2]
    set idcor -1
    set qlogin [quote $login]
    pg_select $dbfd "SELECT idcor FROM corresp WHERE login = '$qlogin'" tab {
        set idcor $tab(idcor)
    }
    if {$idcor == -1} then {
        warning "$argv0: login '$login' non trouv"
        return 1
    }

    set sql "BEGIN WORK ; LOCK rr ; LOCK rr_ip ; LOCK role_mail"
    if {! [execsql $dbfd $sql m]} then { erreur $m }

    if {! ([lire-machines $dbfd] &&
	   [lire-autres-rr $dbfd] &&
	   [lire-rolemail $dbfd] &&
	   [lire-domaine $dbfd] &&
	   [lire-alias $dbfd]) } then {
	execsql $dbfd "ABORT WORK" m
	pg_disconnect $dbfd
	exit 1
    }

    set fichier [lindex $argv 0]
    set fd [open $fichier "r"]
    if {! [remplir-rolemail $dbfd $idcor $fd]} then {
	execsql $dbfd "ABORT WORK" m
	pg_disconnect $dbfd
	exit 1
    }
    close $fd

    set fichier [lindex $argv 1]
    set fd [open $fichier "r"]
    if {! [remplir-relaisdom $dbfd $fd]} then {
	execsql $dbfd "ABORT WORK" m
	pg_disconnect $dbfd
	exit 1
    }
    close $fd

    set fichier "(null)"

    set sql "COMMIT WORK"
    if {! [execsql $dbfd $sql m]} then { erreur $m }

    pg_disconnect $dbfd

    return 0
}

#
# Tout dmarre ici...
#

exit [main $argv0 $argv]
