#!%TCLSH%

# $Id: admgrpmodif,v 1.8 2008/02/13 15:25:09 pda Exp $

#
# Script pour enregistrer les caractristiques associes  un groupe
#
# Appel par : index.htgt
#
# Paramtres (formulaire ou URL) :
#	- orggrp : nom du groupe originel ou "::nouveau"
#	- newgrp : nom du groupe modifi (eventuellement)
#	- admin : droit d'administration (0 ou 1)
#	- confirm : oui ou non
#	- loginN : les logins des membres du groupe
#	- domaineN : les noms des domaines valids pour ce groupe
#	- tridomN : la classe de tri d'un domaine (si vide, suppression)
#	- rolemailN : capacit d'diter les rles mail pour ce domaine (0 ou 1)
#	- rolewebN : capacit d'diter les rles web pour ce domaine (0 ou 1)
#	- reseauN : les id des rseaux valides pour ce groupe
#	- triresN : la classe de tri d'un rseau (si vide, suppression)
#	- dhcpN : capacit d'diter les intervalles DHCP pour ce rseau (0 ou 1)
#	- aclN : capacit d'diter les ACL pour ce rseau (0 ou 1)
#	- adrN et allow_denyN : droits IP associs  ce groupe
#	- tridhcpprofN : classe de tri d'un profil DHCP (si vide, suppression)
#	- nomdhcpprofN : nom du profil DHCP
#
# Historique
#   2002/05/21 : pda/jean : cration
#   2002/07/09 : pda      : ajout de nologin
#   2003/05/13 : pda/jean : utilisation de la base d'authentification
#   2004/01/14 : pda/jean : ajout IPv6
#   2004/02/12 : pda/jean : ajout rles
#   2004/08/06 : pda/jean : extensions des droits sur les rseaux
#   2005/04/08 : pda/jean : profils dhcp
#   2007/10/10 : pda/jean : centralisation de l'administration des groupes
#

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)/admgrpmodif.html
set conf(confirm)	$conf(lib)/admgrpconfirm.html
set conf(confsuppr)	$conf(lib)/admgrpconfsuppr.html
set conf(supprok)	$conf(lib)/admgrpsupprok.html

#
# Quelques paramtres du script
#

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

set conf(form) {
	{confirm		1 1}
	{orggrp			1 1}
	{newgrp			1 1}
	{admin			1 1}
	{login[0-9]+		0 9999}
	{tridom[0-9]+		0 9999}
	{domaine[0-9]+		0 9999}
	{rolemail[0-9]+		0 9999}
	{roleweb[0-9]+		0 9999}
	{trires[0-9]+		0 9999}
	{reseau[0-9]+		0 9999}
	{dhcp[0-9]+		0 9999}
	{acl[0-9]+		0 9999}
	{adr[0-9]+		0 9999}
	{allow[0-9]+		0 9999}
	{tridhcpprof[0-9]+	0 9999}
	{nomdhcpprof[0-9]+	0 9999}
}

#
# 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)

##############################################################################
# Procdures utilitaires
##############################################################################

#
# Valider le nom du groupe, et rcuprer son identifiant numrique
#

proc valide-groupe {dbfd groupe existant} {
    global conf

    set qgroupe [::pgsql::quote $groupe]
    set idgrp -1
    pg_select $dbfd "SELECT idgrp FROM groupe WHERE nom = '$qgroupe'" tab {
	set idgrp $tab(idgrp)
    }

    if {$existant} then {
	# On veut que le groupe existe
	if {$idgrp == -1} then {
	    ::webapp::error-exit $conf(err) "Groupe '$groupe' non trouv"
	}
    } else {
	# On veut que le groupe n'existe pas encore
	# Vrifier d'abord la syntaxe...
	set msg [syntaxe-groupe $groupe]
	if {! [string equal $msg ""]} then {
	    ::webapp::error-exit $conf(err) $msg
	}
	# ... et ensuite, vrifier que le groupe est inconnu
	if {$idgrp != -1} then {
	    ::webapp::error-exit $conf(err) "Le groupe '$groupe' existe dj"
	}
    }

    return $idgrp
}

#
# Suppression d'un groupe
#

proc supprime-groupe {dbfd idgrp idorphelin} {

    set ltab {groupe corresp dr_reseau dr_mbox dr_ip dr_dom dr_dhcpprofil} 
    if {! [::pgsql::lock $dbfd $ltab msg]} then {
	return $msg
    } 

    #
    # Supprime les droits
    #

    foreach table {dr_reseau dr_mbox dr_ip dr_dom dr_dhcpprofil} {
	set sql "DELETE FROM $table WHERE idgrp = $idgrp"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    return $msg
	}
    }

    #
    # Extrait tous les correspondants qui doivent rester orphelins
    #

    set sql "SELECT corresp.idcor FROM corresp, rr
		WHERE corresp.idgrp = $idgrp AND rr.idcor = corresp.idcor
		GROUP BY corresp.idcor"
    
    set lidcor {}
    pg_select $dbfd $sql tab {
	lappend lidcor $tab(idcor)
    }

    # 
    # Raffecter ces correspondants
    # 

    if {[llength $lidcor] > 0} then {
	set lcor [join $lidcor ","]
	set sql "UPDATE corresp SET idgrp = $idorphelin, present = 0
		    WHERE idcor IN ($lcor)"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    return $msg
	} 
    }

    #
    # Supprime les correspondants restants et le groupe
    #

    foreach table {corresp groupe} {
	set sql "DELETE FROM $table WHERE idgrp = $idgrp"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    return $msg
	}
    }

    if {! [::pgsql::unlock $dbfd "commit" msg]} then {
	return $msg
    }

    return ""
}

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

proc main {} {
    global conf
    global ah

    #
    # Initialisation
    #

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

    set orggrp  [lindex $ftab(orggrp) 0]
    set newgrp  [lindex $ftab(newgrp) 0]
    set confirm [lindex $ftab(confirm) 0]

    #
    # Crer le groupe des orphelins si ncessaire
    #

    set idorphelin -1
    pg_select $dbfd "SELECT idgrp FROM groupe WHERE nom = ''" tab {
	set idorphelin $tab(idgrp)
    }
    
    if {$idorphelin == -1} then {
	set sql "INSERT INTO groupe (nom,admin) VALUES ('',0)"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    return $msg
	} 
	pg_select $dbfd "SELECT idgrp FROM groupe WHERE nom = ''" tab {
	    set idorphelin $tab(idgrp)
	}
    }

    #
    # Dterminer dans quel cas on se trouve
    #

    set etat [string equal $orggrp "::nouveau"][string equal $newgrp ""] 
    switch $etat {
	11 {
	    ::webapp::error-exit $conf(err) "Il faut saisir un nom de groupe"
	}
	01 {
	    set action "suppression"
	}
	10 {
	    set action "cration"
	    valide-groupe $dbfd $newgrp 0
	    set msgact "cration du groupe $newgrp"
	    set idgrp -1
	}
	00 {
	    set action "dition"
	    set msgact "modification du groupe $orggrp"
	    set idgrp [valide-groupe $dbfd $orggrp 1]

	    # Renommage
	    if {! [string equal $orggrp $newgrp]} then {
		valide-groupe $dbfd $newgrp 0
	    }
	}
    }

    #
    # Suppression
    #

    if {[string equal $action "suppression"]} then {
	set idgrp [valide-groupe $dbfd $orggrp 1]
	if {! [string equal $confirm "oui"]} then {
	    # Demander confirmation
	    set ftab(confirm)	{oui}
	    set lchamps [array names ftab]
	    set hidden  [::webapp::hide-parameters $lchamps ftab]
	    ::webapp::send html [::webapp::file-subst $conf(confsuppr) \
				[list \
					[list %ORGGRP%	$orggrp] \
					[list %HIDDEN%	$hidden] \
				    ] \
			    ]
	} else {
	    # Procder  la suppression
	    set msg [supprime-groupe $dbfd $idgrp $idorphelin]
	    if {! [string equal $msg ""]} then {
		::webapp::error-exit $conf(err) \
				    "Suppression impossible ($msg)"
	    }
	    ::webapp::send html [::webapp::file-subst $conf(supprok) \
				[list \
					[list %ORGGRP%	$orggrp] \
				    ] \
			    ]
	}
	exit 0
    }

    #
    # Tout ce qui suit concerne la creation ou la modification d'un
    # groupe existant
    #
    

## DEBUT VALIDATION EXISTANCE ET DROITS#####################################

    #
    # Tester le champ admin
    #

    set admin [lindex $ftab(admin) 0]
    if {! ([string equal $admin 0] || [string equal $admin 1])} then {
	::webapp::error-exit $conf(err) "Champ 'admin' invalide"
    }

    #
    # Tester les logins :
    # - rcuprer tous les logins
    # - noter les orphelins  raffecter
    # - signaler une erreur si le login est dj affect  un autre groupe
    # - noter les logins  crer
    # - noter les logins  supprimer
    #
    
    # On rcupre tous les correspondants

    set sql "SELECT corresp.login, groupe.nom, groupe.idgrp
		FROM corresp, groupe
		WHERE corresp.idgrp = groupe.idgrp"
    pg_select $dbfd $sql tab {
	if {[string equal $tab(nom) ""]} then {
	    set torph($tab(login)) ""
	} else {
	    set tcor($tab(login)) [list $tab(idgrp) $tab(nom)]
	}
    }

    set lcorcreate {}
    set lcoraffect {}
    set lcordelete {}
    set n 1
    while {[info exists ftab(login$n)]} {
	set login [string trim [lindex $ftab(login$n) 0]]
	if {[string length $login] > 0} then {
	    if {[info exists torph($login)]} then {
		lappend lcoraffect $login
	    } elseif {[info exists tcor($login)]} then {
		if {$idgrp != [lindex $tcor($login) 0]} then {
		    set g [lindex $tcor($login) 1]
		    ::webapp::error-exit $conf(err) \
			"Login '$login' dj affect au groupe '$g'"
		}
		unset tcor($login)
	    } else {
		lappend lcorcreate $login
	    }
	}
	incr n
    }

    foreach login [array names tcor] {
	if {[lindex $tcor($login) 0] == $idgrp} then {
	    lappend lcordelete $login
	}
    }

    #
    # Tester la validit des domaines, et construire la liste
    # des identificateurs de domaines
    #

    foreach ld [::pgsql::getcols $dbfd domaine "" "" {iddom nom}] {
	set iddom [lindex $ld 0]
	set nom   [lindex $ld 1]
	set tabdom($nom) $iddom
    }

    set liddom {}
    set n 1
    while {[info exists ftab(tridom$n)] && [info exists ftab(domaine$n)]} {
	set tri [string trim [lindex $ftab(tridom$n) 0]]
	if {[string length $tri] > 0} then {
	    if {! [regexp -- {^[0-9]+$} $tri]} then {
		::webapp::error-exit $conf(err) "Classe de tri de domaine invalide ($tri)"
	    }

	    set domaine [string trim [lindex $ftab(domaine$n) 0]]
	    if {! [info exists tabdom($domaine)]} then {
		::webapp::error-exit $conf(err) "Domaine invalide ($domaine)"
	    }

	    if {! [info exists ftab(rolemail$n)]} then {
		set ftab(rolemail$n) 0
	    }
	    set rolemail [string trim [lindex $ftab(rolemail$n) 0]]
	    if {! [regexp -- {^[01]$} $rolemail]} then {
		::webapp::error-exit $conf(err) "Role mail invalide ($rolemail)"
	    }

	    if {! [info exists ftab(roleweb$n)]} then {
		set ftab(roleweb$n) 0
	    }
	    set roleweb [string trim [lindex $ftab(roleweb$n) 0]]
	    if {! [regexp -- {^[01]$} $roleweb]} then {
		::webapp::error-exit $conf(err) "Role web invalide ($roleweb)"
	    }

	    lappend liddom [list $tri $tabdom($domaine) $rolemail $roleweb]
	}

	incr n
    }

    #
    # Tester la validit des identificateurs de rseaux et construire
    # la liste des identificateurs de rseaux
    #

    foreach ld [::pgsql::getcols $dbfd reseau "" "" {idreseau adr4 adr6 dhcp}] {
	set idreseau [lindex $ld 0]
	set ladr {}
	foreach i {1 2} {
	    set a [lindex $ld $i]
	    if {! [string equal $a ""]} then {
		lappend ladr $a
	    }
	}
	set tabres($idreseau) $ladr
	set tabdhcp($idreseau) [lindex $ld 3]
    }

    set lidres {}
    set n 1
    while {[info exists ftab(trires$n)] && [info exists ftab(reseau$n)]} {
	set tri [string trim [lindex $ftab(trires$n) 0]]
	if {[string length $tri] > 0} then {
	    if {! [regexp -- {^[0-9]+$} $tri]} then {
		::webapp::error-exit $conf(err) "Classe de tri de rseau invalide ($tri)"
	    }

	    set idreseau [string trim [lindex $ftab(reseau$n) 0]]
	    if {! [info exists tabres($idreseau)]} then {
		::webapp::error-exit $conf(err) "Rseau invalide ($idreseau)"
	    }

	    if {! [info exists ftab(dhcp$n)]} then {
		set ftab(dhcp$n) 0
	    }
	    set dhcp [string trim [lindex $ftab(dhcp$n) 0]]
	    if {! [regexp -- {^[01]$} $dhcp]} then {
		::webapp::error-exit $conf(err) "Droit DHCP invalide ($dhcp)"
	    }

	    if {! [info exists ftab(acl$n)]} then {
		set ftab(acl$n) 0
	    }
	    set acl [string trim [lindex $ftab(acl$n) 0]]
	    if {! [regexp -- {^[01]$} $acl]} then {
		::webapp::error-exit $conf(err) "Droit ACL invalide ($acl)"
	    }

	    lappend lidres [list $tri $idreseau $dhcp $acl]
	}

	incr n
    }

    #
    # Tester la validit syntaxique des droits IP
    #

    set n 1
    set ldrip {}
    set droits_allow {}
    while {[info exists ftab(adr$n)] && [info exists ftab(allow$n)]} {
	set allow_deny [lindex $ftab(allow$n) 0]
	if {!([string equal $allow_deny "0"] || \
		[string equal $allow_deny "1"])} then {
	    ::webapp::error-exit $conf(err) \
			"Valeur incorrecte pour allow/deny '$allow_deny'"
	}

	set adr [string trim [lindex $ftab(adr$n) 0]]
	if {[string length $adr] != 0} then {
	    set m [syntaxe-ip $dbfd $adr "cidr"]
	    if {[string length $m] > 0} then {
		::webapp::error-exit $conf(err) "CIDR incorrect '$adr'"
	    }

	    lappend ldrip [list $allow_deny $adr]
	    if {$allow_deny} then {
		lappend droits_allow $adr
	    }
	}

	incr n
    }

    #
    # Tester la validit des noms de profils DHCP
    #

    foreach ld [::pgsql::getcols $dbfd dhcpprofil "" "" {iddhcpprofil nom}] {
	set iddhcpprofil [lindex $ld 0]
	set nom          [lindex $ld 1]
	set tabdhcpprofil($nom) $iddhcpprofil
    }

    set lidprof {}
    set n 1
    while {[info exists ftab(tridhcpprof$n)] && [info exists ftab(nomdhcpprof$n)]} {
	set tri [string trim [lindex $ftab(tridhcpprof$n) 0]]
	if {[string length $tri] > 0} then {
	    if {! [regexp -- {^[0-9]+$} $tri]} then {
		::webapp::error-exit $conf(err) \
			"Classe de tri de profil DHCP invalide ($tri)"
	    }

	    set dhcpprofil [string trim [lindex $ftab(nomdhcpprof$n) 0]]
	    if {! [info exists tabdhcpprofil($dhcpprofil)]} then {
		::webapp::error-exit $conf(err) \
			"Profil DHCP invalide ($dhcpprofil)"
	    }

	    lappend lidprof [list $tri $tabdhcpprofil($dhcpprofil)]
	}

	incr n
    }

## FIN VALIDATION EXISTANCE ET DROITS ####################################

    #
    # Tester la cohrence des donnes
    #

    if {! [string equal $confirm "oui"]} then {
	#
	# - au moins un domaine
	# - au moins un rseau
	# - tout rseau a un ou plusieurs droits IP affects
	#	autrement dit, un correspondant peut bien accder 
	#	une plage dans les rseaux qui lui sont prsents.
	# - tout droit IP est dans un rseau
	#	autrement dit, on n'affecte pas  un correspondant
	#	des droits plus grands que les rseaux auxquels il
	#	a droit
	# Si une au moins de ces conditions est fausse, on demande
	# confirmation  l'administrateur : on doit pouvoir passer
	# outre (exemple typique : l'administrateur a droit  tous
	# les rseaux via un seul droit CIDR par exemple).
	#

	set incoherences {}

	# logins inexistants dans la base d'authentification

	set u [::webapp::authuser create %AUTO%]
	set n 1
	while {[info exists ftab(login$n)]} {
	    set login [string trim [lindex $ftab(login$n) 0]]
	    if {[string length $login] > 0} then {
		if {[catch {set nb [$ah getuser $login $u]} m]} then {
		    ::webapp::error-exit $conf(err) \
			"Problme dans la base d'authentification ($m)"
		}
		switch $nb {
		    0 {
			lappend incoherences "Le login '$login' n'existe pas"
		    }
		    1 {
			# rien
		    }
		    default {
			::webapp::error-exit $conf(err) "Login '$login' ambigu"
		    }
		}
	    }
	    incr n
	}
	
	# au moins un domaine
	if {[llength $liddom] == 0} then {
	    lappend incoherences "Aucun domaine slectionn"
	}

	# au moins un rseau
	if {[llength $lidres] == 0} then {
	    lappend incoherences "Aucun rseau slectionn"
	}

	# autoriser l'accs dhcp ncessite que le rseau soit dhcp-capable
	foreach r $lidres {
	    set idreseau [lindex $r 1]
	    set dhcp [lindex $r 2]
	    if {$dhcp && ! $tabdhcp($idreseau)} then {
		lappend incoherences "Rseau $tabres($idreseau) n'a pas la capacit DHCP"
	    }
	}

	# tout rseau a au moins un droit de type "allow"
	foreach r $lidres {
	    set idreseau [lindex $r 1]
	    foreach adr $tabres($idreseau) {
		set aucun_droit 1
		foreach dr $droits_allow {
		    pg_select $dbfd "SELECT '$adr' >>= '$dr' AS resultat" tab {
			set resultat $tab(resultat)
		    }
		    if {[string equal $resultat "t"]} then {
			set aucun_droit 0
			break
		    }
		}
		if {$aucun_droit} then {
		    lappend incoherences \
			    "Aucun droit 'allow' trouv pour le rseau '$adr'"
		}
	    }
	}

	# aucun droit de type "allow" n'est plus grand qu'un rseau
	foreach dr $droits_allow {
	    set plus_grand 0
	    foreach r $lidres {
		set idreseau [lindex $r 1]
		foreach adr $tabres($idreseau) {
		    set sql "SELECT cidr '$adr' << cidr '$dr' AS resultat"
		    pg_select $dbfd $sql tab {
			set resultat $tab(resultat)
		    }
		    if {[string equal $resultat "t"]} then {
			set plus_grand 1
			break
		    }
		}
	    }

	    if {$plus_grand} then {
		lappend incoherences "Le droit 'allow - $dr' est trop grand"
	    }
	}

	#
	# S'il y a des incohrences, les annoncer et demander
	# confirmation.
	#

	if {[llength $incoherences] > 0} then {
	    set ftab(confirm)	{oui}
	    set lchamps [array names ftab]
	    set hidden  [::webapp::hide-parameters $lchamps ftab]
	    set message [join $incoherences "<BR>\n"]
	    ::webapp::send html [::webapp::file-subst $conf(confirm) \
				[list \
					[list %MSGACT%	$msgact] \
					[list %ORGGRP%	$orggrp] \
					[list %HIDDEN%	$hidden] \
					[list %MESSAGE%	$message] \
				    ] \
			    ]
	    exit 0
	}
    }
## FIN VALIDATION COHERENCE ####################################

    #
    # Si on arrive ici, c'est que les donnes sont cohrentes,
    # ou qu'on a eu confirmation de la demande. Il faut donc
    # enregistrer les donnes dans la base.
    # Toutes les modifications se font par suppression totale
    # des lments, puis r-insertion  partir de ce qui est
    # fourni dans le formulaire
    #

    set ltab {groupe corresp dr_reseau dr_mbox dr_ip dr_dom dr_dhcpprofil} 
    if {! [::pgsql::lock $dbfd $ltab msg]} then {
	return $msg
    } 

    # Cration du groupe si ncessaire

    if {[string equal $action "cration"]} then {
	set qnewgrp [::pgsql::quote $newgrp]
	set sql "INSERT INTO groupe (nom,admin)
		    VALUES ('$qnewgrp',$admin)"
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	    ::pgsql::unlock $dbfd "abort" m
	    return $msg
	} 
    } else {

	# dition d'un groupe existant

	set qorggrp [::pgsql::quote $orggrp]

	if {! [string equal $orggrp $newgrp]} then {

	    # Renommage du groupe
	    set qnewgrp [::pgsql::quote $newgrp]
	    set sql "UPDATE groupe SET nom = '$qnewgrp' WHERE nom = '$qorggrp'"
	    if {! [::pgsql::execsql $dbfd $sql msg]} then {
		::pgsql::unlock $dbfd "abort" m
		return $msg
	    }
	}
    }

    # Rcupre l'identifiant du groupe

    set qnewgrp [::pgsql::quote $newgrp]
    set idgrp -1
    pg_select $dbfd "SELECT idgrp FROM groupe WHERE nom = '$qnewgrp'" tab {
	set idgrp $tab(idgrp)
    }
    if {$idgrp == -1} then {
	::webapp::error-exit $conf(err) \
		"Erreur interne : groupe '$newgrp' non trouv"
    }

    # Mettre a jour les attributs du groupe
    lappend cmd "UPDATE groupe SET admin = $admin WHERE idgrp = $idgrp"

    # Crer ou affecter les correspondants

    if {[llength $lcorcreate] > 0} then {
	foreach login $lcorcreate {
	    set qlogin [::pgsql::quote $login]
	    lappend cmd "INSERT INTO corresp (login,present,idgrp)
			    VALUES ('$qlogin',1,$idgrp)"
	}
    }
    if {[llength $lcoraffect] > 0} then {
	foreach login $lcoraffect {
	    set qlogin [::pgsql::quote $login]
	    lappend cmd "UPDATE corresp SET idgrp = $idgrp
			    WHERE login = '$qlogin'"
	}
    }

    # On raffecte tous les correspondants  supprimer au groupe orphelin

    if {[llength $lcordelete] > 0} then {
	foreach login $lcordelete {
	    set qlogin [::pgsql::quote $login]
	    lappend cmd "UPDATE corresp SET idgrp = $idorphelin
			    WHERE login = '$qlogin'"
	}
    }

    # On nettoie tous les correspondants inutiles

    lappend cmd "DELETE FROM corresp 
			WHERE idgrp = $idorphelin 
			    AND idcor NOT IN (SELECT DISTINCT idcor FROM rr)"

    # Les domaines autoriss pour le groupe

    lappend cmd "DELETE FROM dr_dom WHERE idgrp = $idgrp"

    foreach e $liddom {
	set tri      [lindex $e 0]
	set iddom    [lindex $e 1]
	set rolemail [lindex $e 2]
	set roleweb  [lindex $e 3]
	lappend cmd "INSERT INTO dr_dom (idgrp, iddom, tri, rolemail, roleweb)
			VALUES ($idgrp, $iddom, $tri, $rolemail, $roleweb)"
    }

    # Les rseaux autoriss pour le groupe

    lappend cmd "DELETE FROM dr_reseau WHERE idgrp = $idgrp"

    foreach r $lidres {
	set tri      [lindex $r 0]
	set idreseau [lindex $r 1]
	set dhcp     [lindex $r 2]
	set acl      [lindex $r 3]
	lappend cmd "INSERT INTO dr_reseau (idgrp, idreseau, tri, dhcp, acl)
			VALUES ($idgrp, $idreseau, $tri, $dhcp, $acl)"
    }

    # Les droits IP associs au groupe

    lappend cmd "DELETE FROM dr_ip WHERE idgrp = $idgrp"

    foreach e $ldrip {
	set allow_deny [lindex $e 0]
	set adr        [lindex $e 1]
	lappend cmd "INSERT INTO dr_ip VALUES ($idgrp, '$adr', $allow_deny)"
    }

    # Les profils DHCP visibles par le groupe

    lappend cmd "DELETE FROM dr_dhcpprofil WHERE idgrp = $idgrp"

    foreach e $lidprof {
	set tri          [lindex $e 0]
	set iddhcpprofil [lindex $e 1]
	lappend cmd "INSERT INTO dr_dhcpprofil (idgrp, iddhcpprofil, tri)
			VALUES ($idgrp, $iddhcpprofil, $tri)"
    }

    #
    # Modifications dans la base
    #

    foreach sql $cmd {
	if {! [::pgsql::execsql $dbfd $sql msg]} then {
	   ::pgsql::unlock $dbfd "abort" m
	   ::webapp::error-exit $conf(err) \
			"L'opration '$sql' a chou. Abandon.\n$msg"
	}
    }

    if {! [::pgsql::unlock $dbfd "commit" msg]} then {
       ::pgsql::unlock $dbfd "abort" m
       ::webapp::error-exit $conf(err) "L'insertion a chou. Abandon.\n$msg"
    }

    #
    # Rcupration du code HTML d'affichage des caractristiques
    # du groupe auquel appartient le correspondant
    #

    set grospaquet [info-groupe $dbfd $idgrp]
    set tablogins         [lindex $grospaquet 0]
    set tabreseaux        [lindex $grospaquet 1]
    set tabcidrhorsreseau [lindex $grospaquet 2]
    set tabdomaines       [lindex $grospaquet 3]
    set tabdhcpprofils    [lindex $grospaquet 4]

    #
    # Sortie du rsultat
    #

    ::webapp::send html [::webapp::file-subst $conf(page) \
		    [list \
			[list %NEWGRP% $newgrp] \
			[list %TABLOGINS% $tablogins] \
			[list %TABRESEAUX% $tabreseaux] \
			[list %TABCIDRHORSRESEAU% $tabcidrhorsreseau] \
			[list %TABDOMAINES% $tabdomaines] \
			[list %TABDHCPPROFILS% $tabdhcpprofils] \
			] \
		    ]

    #
    # Dconnexion de la base
    #

    fermer-base $dbfd
}

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