#!%TCLSH%

#
# Script pour enregistrer les caractristiques associes  un groupe
#
# Appel par : index.htgt
#
# Paramtres (formulaire ou URL) :
#	- groupe : nom du groupe
#	- confirm : oui ou non
#	- domaineN : les noms des domaines valids pour ce groupe
#	- triN : la classe de tri associe  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)
#	- reseaux : les id des rseaux valids pour ce groupe
#	- adrN et allow_denyN : droits IP associs  ce groupe
#
# 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
#

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

#
# Quelques paramtres du script
#

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

set conf(form) {
	{confirm		1 1}
	{groupe			1 1}
	{tri[0-9]+		0 9999}
	{domaine[0-9]+		0 9999}
	{rolemail[0-9]+		0 9999}
	{roleweb[0-9]+		0 9999}
	{reseaux		0 9999}
	{adr[0-9]+		0 9999}
	{allow[0-9]+		0 9999}
}

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

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

#
# On y va !
#

# ::webapp::cgidebug ; exit

source $conf(libdns)

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

proc main {} {
    global conf

    #
    # Initialisation
    #

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

    set groupe [lindex $ftab(groupe) 0]
    set confirm [lindex $ftab(confirm) 0]

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

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

    if {$idgrp == -1} then {
	::webapp::error-exit $conf(err) "Groupe '$groupe' non trouv"
    }

    #
    # 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(tri$n)] && [info exists ftab(domaine$n)]} {
	set tri [string trim [lindex $ftab(tri$n) 0]]
	if {[string length $tri] > 0} then {
	    if {! [regexp -- {^[0-9]+$} $tri]} then {
		::webapp::error-exit $conf(err) "Classe de tri 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}] {
	set idres [lindex $ld 0]
	set ladr {}
	foreach i {1 2} {
	    set a [lindex $ld $i]
	    if {! [string equal $a ""]} then {
		lappend ladr $a
	    }
	}
	set tabres($idres) $ladr
    }

    set lidres {}
    foreach idreseau $ftab(reseaux) {
	if {! [info exists tabres($idreseau)]} then {
	    ::webapp::error-exit $conf(err) \
			"Rseau d'identificateur '$idreseau' non trouv"
	}
	lappend lidres $idreseau
    }

    #
    # 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 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 {}

	# 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"
	}

	# tout rseau a au moins un droit de type "allow"
	foreach idres $lidres {
	    foreach adr $tabres($idres) {
		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 idres $lidres {
		foreach adr $tabres($idres) {
		    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 %GROUPE%	$groupe] \
					[list %HIDDEN%	$hidden] \
					[list %MESSAGE%	$message] \
				    ] \
			    ]
	    exit 0
	}
    }

    #
    # 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 cmd {}

    lappend cmd "LOCK dr_dom ; LOCK plage ; LOCK dr_ip"

    # 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 plage WHERE idgrp = $idgrp"

    foreach idres $lidres {
	lappend cmd "INSERT INTO plage VALUES ($idgrp, $idres)"
    }

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

    #
    # Modifications dans la base
    #

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

    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 tabreseaux        [lindex $grospaquet 0]
    set tabcidrhorsreseau [lindex $grospaquet 1]
    set tabdomaines       [lindex $grospaquet 2]

    if {[string length $tabcidrhorsreseau] == 0} then {
	set titrecidrhorsreseau ""
    } else {
	set titrecidrhorsreseau "Droits non rattachs  des rseaux"
    }


    #
    # Sortie du rsultat
    #

    ::webapp::send html [::webapp::file-subst $conf(page) \
		    [list \
			[list %GROUPE% $groupe] \
			[list %TABRESEAUX% $tabreseaux] \
			[list %TITRECIDRHORSRESEAU% $titrecidrhorsreseau] \
			[list %TABCIDRHORSRESEAU% $tabcidrhorsreseau] \
			[list %TABDOMAINES% $tabdomaines] \
			] \
		    ]

    #
    # Dconnexion de la base
    #

    fermer-base $dbfd
}

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