#!%TCLSH%

# $Id: admmxmodif,v 1.5 2007/11/14 15:27:28 pda Exp $

#
# Script pour enregistrer une modification de mx
#
# Appel par : admmxsel.htgt
#
# Paramtres (formulaire ou URL) : aucun
#
# Historique
#   2003/04/24 : pda/jean : cration
#   2003/05/13 : pda/jean : utilisation de la base d'authentification
#   2004/03/04 : pda/jean : mise en commun de valide-mx
#   2007/10/25 : jean     : log des actions de modification
#

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)/admmxmodif.html

#
# Quelques paramtres du script
#

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

set conf(form) {
	{nom			1 1}
	{domaine		1 1}

	{priorite[0-9]+		0 9999}
	{nom[0-9]+		0 9999}
	{domaine[0-9]+		0 9999}

	{prioriten[0-9]+	0 9999}
	{nomn[0-9]+		0 9999}
	{domainen[0-9]+		0 9999}
}

set conf(tableau) {
    global {
	chars {12 normal}
	columns {20 80}
	botbar {yes}
	align {left}
    }
    motif {Titre} {
	title {yes}
	topbar {yes}
	chars {bold}
	vbar {yes}
	colonne { }
	vbar {yes}
	colonne { }
	vbar {yes}
    }
    motif {Normal} {
	vbar {yes}
	colonne { }
	vbar {yes}
	colonne { }
	vbar {yes}
    }
}

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

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

#
# On y va !
#

# ::webapp::cgidebug ; exit

source $conf(libdns)

##############################################################################
# Fonctions utilitaires
##############################################################################

#
# Insre une liste de mx dans la base
#
# Entre :
#   - paramtres :
#	- dbfd : accs  la base
#	- idrr : id du RR
#	- lmx : liste au format spcifi dans valide-mx
# Sortie :
#   - valeur de retour : chane vide si ok, ou message d'erreur
#
# Historique
#   2003/04/25 : pda/jean : conception
#

proc inserer-mx {dbfd idrr lmx} {
    foreach mx $lmx {
	set prio [lindex $mx 0]
	set idmx [lindex $mx 1]
	set sql "INSERT INTO rr_mx (idrr, priorite, mx)
				VALUES ($idrr, $prio, $idmx)"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    return "Insertion du MX impossible ($msg)"
	}
    }
    return ""
}

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

proc main {} {
    global conf

    #
    # Initialisation
    #

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

    set nom     [lindex $ftab(nom) 0]
    set domaine [lindex $ftab(domaine) 0]

    #
    # Valider le nom du MX et le domaine
    #

    set msg [syntaxe-nom $nom]
    if {[string length $msg] > 0} then {
	::webapp::error-exit $conf(err) $msg
    }

    set msg [valide-domaine $dbfd $tabcor(idcor) $domaine iddom ""]
    if {[string length $msg] > 0} then {
	::webapp::error-exit $conf(err) $msg
    }

    #
    # Rcuprer les informations sur ce nom s'il existe dans la base
    #

    set existe [lire-rr-par-nom $dbfd $nom $iddom tabrr]

    #
    # S'il existe, vrifier que ce n'est pas dj un A ou un CNAME
    # ou autre chose encore qui ne soit pas des MX
    #

    if {$existe} then {
	if {[llength $tabrr(ip)] > 0} then {
	    ::webapp::error-exit $conf(err) "'$nom' a dj des adresses IP."
	}
	if {[llength $tabrr(cname)] > 0} then {
	    ::webapp::error-exit $conf(err) "'$nom' est un alias."
	}

	#
	# Le MX existe, il faut maintenant vrifier que l'utilisateur
	# a bien accs  tous les domaines des MX rfrencs.
	#
	foreach mx $tabrr(mx) {
	    set idmx [lindex $mx 1]
	    if {[lire-rr-par-id $dbfd $idmx tabrrmx] == 0} then {
		::webapp::error-exit $conf(err) "ERREUR INTERNE : table rr_mx rfrence le RR $idmx, non trouv dans la table rr"
	    }
	    set iddom $tabrrmx(iddom)
	    if {! [droit-correspondant-domaine $dbfd $tabcor(idcor) $iddom ""]} then {
		::webapp::error-exit $conf(err) "Le MX '$tabmx(nom).$tabmx(domaine)' rfrence un domaine auquel vous n'avez pas accs"
	    }
	    set tabprio($idmx) [lindex $mx 0]
	}
    }

    #
    # Parcourir la liste des champs de formulaire et constituer une
    # liste de la forme :
    #		{{prio idmx} ... }
    # o :
    #  - prio = priorit numrique (syntaxe entire ok)
    #  - idmx = id d'un RR existant
    #

    set lmx {}
    foreach c [array names ftab] {
	if {[regexp {^priorite(n?)([0-9]+)$} $c bidon n idmx]} then {
	    set idxprio priorite$n$idmx
	    set idxnom  nom$n$idmx
	    set idxdom  domaine$n$idmx
	    if {[info exists ftab($idxprio)] && \
			    [info exists ftab($idxnom)] && \
			    [info exists ftab($idxdom)] \
		    } then {
		set fprio [string trim [lindex $ftab($idxprio) 0]]
		set fnom  [string trim [lindex $ftab($idxnom)  0]]
		set fdom  [string trim [lindex $ftab($idxdom)  0]]
		if {! [string equal $fprio ""]} then {
		    set msg ""
		    set mx [valide-mx $dbfd \
					    $fprio $fnom $fdom \
					    $tabcor(idcor) msg]
		    if {! [string equal $msg ""]} then {
			::webapp::error-exit $conf(err) "$msg pour $fnom.$fdom"
		    }
		    if {[info exists tmx([lindex $mx 1])]} then {
			::webapp::error-exit $conf(err) "$fnom.$fdom spcifi deux fois."
		    }
		    lappend lmx $mx
		}
	    } else {
		::webapp::error-exit $conf(err) "Formulaire non conforme ($idxprio, $idxnom, $idxdom)"
	    }
	}
    }

    #
    # Dbuter la transaction
    #

    if {! [::pgsql::lock $dbfd {} msg]} then {
	::webapp::error-exit $conf(err) "Verrouillage de la base impossible: $msg"
    }

    #
    # Traitement des insertions et suppressions
    #

    if {$existe} then {
	#
	# Supprimer tous les MX ventuels au pralable.
	#

	set sql "DELETE FROM rr_mx WHERE idrr = $tabrr(idrr)"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    ::webapp::error-exit $conf(err) "Suppression des anciens MX impossible: $msg"
	}

	#
	# Si la liste lmx est vide, supprimer le RR
	#

	if {[llength $lmx] == 0} then {
	    #
	    # Supprimer le RR
	    #
	    set sql "DELETE FROM rr WHERE idrr = $tabrr(idrr)"
	    if {! [::pgsql::execsql $dbfd $sql msg]} then {
		::pgsql::unlock $dbfd "abort" m
		::webapp::error-exit $conf(err) "Suppression du RR '$nom.$domaine' impossible: $msg"
	    }
	} else {
	    #
	    # Insrer les RR des MX
	    #
	    set msg [inserer-mx $dbfd $tabrr(idrr) $lmx]
	    if {! [string equal $msg ""]} then {
		::pgsql::unlock $dbfd "abort" m
		::webapp::error-exit $conf(err) "Ajout des MX impossible: $msg"
	    }
	}
    } else {
	#
	# Le RR n'existe pas.
	#

	if {[llength $lmx] == 0} then {
	    #
	    # Cas sans objet : l'utilisateur a demand  crer un
	    # MX, mais n'a saisi aucun MX.
	    #
	    ::pgsql::unlock $dbfd "abort" m
	    ::webapp::error-exit $conf(err) "Pas de cration de MX pour '$nom.$domaine'."
	} else {
	    #
	    # Crer le RR
	    #

	    # XXX : pas de commentaire ni de responsable... peut-tre plus tard
	    set msg [ajouter-rr $dbfd $nom $iddom "" 0 "" "" "" "" \
				$tabcor(idcor) tabrr]
	    if {! [string equal $msg ""]} then {
		::webapp::error-exit $conf(err) \
			"Impossible d'insrer '$nom.$domaine' : $msg($msg)"
	    }

	    #
	    # Insrer les RR des MX
	    #
	    set msg [inserer-mx $dbfd $tabrr(idrr) $lmx]
	    if {! [string equal $msg ""]} then {
		::pgsql::unlock $dbfd "abort" m
		::webapp::error-exit $conf(err) "Ajout des MX impossible: $msg"
	    }
	}
    }

    #
    # Dverrouillage, et enregistrement des modifications avant la sortie
    #

    if {! [::pgsql::unlock $dbfd "commit" msg]} then {
        ::pgsql::unlock $dbfd "abort" m
        return "Dverrouillage impossible, modification annule ('$msg')"
    }

    #
    # Rcapituler les informations ajoutes dans la base.
    #

    if {[llength $lmx] > 0} then {
	set donnees {}
	lappend donnees {Titre Priorit Nom}
	set lm {}
	foreach mx $lmx {
	    # priorit idmx
	    lire-rr-par-id $dbfd [lindex $mx 1] tabmx
	    lappend donnees [list Normal \
				[lindex $mx 0] \
				$tabmx(nom).$tabmx(domaine) \
			    ]
	    lappend lm "$tabmx(nom).$tabmx(domaine)"
	}
	set tableau [::arrgen::output "html" $conf(tableau) $donnees]
	writelog "ajoutmx" $tabcor(login) \
		"ajout des mx [join $lm {, }] pour $nom.$domaine"
    } else {
	set tableau "RR supprim."
	writelog "supprmx" $tabcor(login) "suppression du RR pour $nom.$domaine"
    }

    #
    # Sortie du rsultat
    #

    ::webapp::send html [::webapp::file-subst $conf(page) \
				    [list \
					    [list %TABLEAU% $tableau] \
					    [list %NOM%     $nom] \
					    [list %DOMAINE% $domaine] \
					] \
			    ]

    #
    # Dconnexion de la base
    #

    fermer-base $dbfd
}

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