# $Id: stanzaerror.tcl 1442 2008-05-21 11:36:30Z sergei $
# 

##########################################################################

package provide stanzaerror 1.0

##########################################################################

namespace eval stanzaerror {

    variable NS
    set NS(stanzas) "urn:ietf:params:xml:ns:xmpp-stanzas"

    array set error_type [list \
	auth	    [::msgcat::mc "Authentication Error"] \
	cancel	    [::msgcat::mc "Unrecoverable Error"] \
	continue    [::msgcat::mc "Warning"] \
	modify	    [::msgcat::mc "Request Error"] \
	wait	    [::msgcat::mc "Temporary Error"]]

    set defined_error_conditions {}
    # Code is zero iff the condition isn't mentioned in XEP-0086
    foreach {clist lcode type cond description} [list \
      {400}	    400 modify	bad-request		[::msgcat::mc "Bad Request"] \
      {409}	    409 cancel	conflict		[::msgcat::mc "Conflict"] \
      {501}	    501 cancel	feature-not-implemented [::msgcat::mc "Feature Not Implemented"] \
      {403}	    403 auth	forbidden		[::msgcat::mc "Forbidden"] \
      {302}	    302	modify	gone			[::msgcat::mc "Gone"] \
      {500}	    500 wait	internal-server-error   [::msgcat::mc "Internal Server Error"] \
      {404}	    404 cancel	item-not-found		[::msgcat::mc "Item Not Found"] \
      {}	    400 modify	jid-malformed		[::msgcat::mc "JID Malformed"] \
      {406}	    406	modify	not-acceptable		[::msgcat::mc "Not Acceptable"] \
      {405}	    405 cancel	not-allowed		[::msgcat::mc "Not Allowed"] \
      {401}	    401	auth	not-authorized		[::msgcat::mc "Not Authorized"] \
      {402}	    402 auth	payment-required	[::msgcat::mc "Payment Required"] \
      {}	    404 wait	recipient-unavailable   [::msgcat::mc "Recipient Unavailable"] \
      {}	    302 modify	redirect		[::msgcat::mc "Redirect"] \
      {407}	    407 auth	registration-required   [::msgcat::mc "Registration Required"] \
      {}	    404 cancel	remote-server-not-found [::msgcat::mc "Remote Server Not Found"] \
      {408 504}     504 wait	remote-server-timeout   [::msgcat::mc "Remote Server Timeout"] \
      {}	    500 wait	resource-constraint	[::msgcat::mc "Resource Constraint"] \
      {502 503 510} 503 cancel	service-unavailable	[::msgcat::mc "Service Unavailable"] \
      {}	    407 auth	subscription-required   [::msgcat::mc "Subscription Required"] \
      {}	    500 any	undefined-condition	[::msgcat::mc "Undefined Condition"] \
      {}	    400 wait	unexpected-request	[::msgcat::mc "Unexpected Request"]] \
    {
	lappend defined_error_conditions $cond
	set error_description($type,$cond) $description
	# XEP-0086
	foreach code $clist {
	    set error_type_descelem($code) [list $type $cond]
	}
	set legacy_error_codes($cond) $lcode
    }

    # Error messages from jabberd 1.4
    # [::msgcat::mc "Access Error"]
    # [::msgcat::mc "Address Error"]
    # [::msgcat::mc "Application Error"]
    # [::msgcat::mc "Format Error"]
    # [::msgcat::mc "Not Found"]
    # [::msgcat::mc "Not Implemented"]
    # [::msgcat::mc "Recipient Error"]
    # [::msgcat::mc "Remote Server Error"]
    # [::msgcat::mc "Request Timeout"]
    # [::msgcat::mc "Server Error"]
    # [::msgcat::mc "Unauthorized"]
    # [::msgcat::mc "Username Not Available"]
}

##########################################################################

proc stanzaerror::register_errortype {type description} {
    variable error_type

    set error_type($type) $description
}

##########################################################################

proc stanzaerror::register_error {lcode type cond description} {
    variable defined_error_conditions
    variable error_description
    variable error_type_descelem

    lappend defined_error_conditions $cond
    set error_description($type,$cond) $description
    set legacy_error_codes($cond) $lcode
}

##########################################################################

proc stanzaerror::error_to_list {errmsg} {
    variable NS
    variable error_type
    variable defined_error_conditions
    variable error_description
    variable error_type_descelem

    if {$errmsg == [::msgcat::mc "Disconnected"]} {
	return [list none none [::msgcat::mc "Disconnected"]]
    }

    lassign $errmsg code desc
    if {[string is integer $code]} {
	if {[info exists error_type_descelem($code)]} {
	    lassign $error_type_descelem($code) type descelem
	} else {
	    lassign {none none} type descelem
	}
	return [list $type $descelem "$code ([::msgcat::mc $desc])"]
    } else {
	set type $code
	set errelem $desc
	set condition "undefined-condition"
	set description ""
	set textdescription ""
	jlib::wrapper:splitxml $errelem tag vars isempty chdata children
	foreach child $children {
	    jlib::wrapper:splitxml $child tag1 vars1 isempty1 chdata1 children1
	    set xmlns [jlib::wrapper:getattr $vars1 xmlns]
	    set cond $tag1
	    switch -- $cond {
		text {
		    if {$xmlns == $NS(stanzas)} {
			set textdescription ": $chdata1"
		    }
		}
		undefined-condition {
		    # TODO
		    set description $error_description(any,undefined-condition)
		}
		default {
		    if {[lsearch -exact $defined_error_conditions $cond] >= 0} {
			set condition $cond
			if {[info exists error_description($type,$cond)] && \
				($description == "")} {
			    set description $error_description($type,$cond)
			}
		    } else {
			# TODO
		    }
		}
	    }
	}
	if {[info exists error_type($type)]} {
	    set typedesc $error_type($type)
	}
	set res ""
	if {$description != ""} {
	    set res $description
	}
	if {[info exists typedesc] && $typedesc != ""} {
	    if {$res == ""} {
		set res $typedesc
	    } else {
		set res "$typedesc ($res)"
	    }
	}
	return [list $type $condition "$res$textdescription"]
    }
}

##########################################################################

proc stanzaerror::error {type condition args} {
    return [eval {xmpp_error $type $condition} $args]
}

##########################################################################

proc stanzaerror::legacy_error {type condition args} {
    variable NS
    variable legacy_error_codes
    variable error_description

    if {[info exists legacy_error_codes($condition)] && \
	    $legacy_error_codes($condition)} {
	set code $legacy_error_codes($condition)
    } else {
	set code 501
    }
    if {[info exists error_description($type,$condition)]} {
	set description $error_description($type,$condition)
    } else {
	set description ""
    }
    set xml ""
    foreach {opt val} $args {
	switch -- $opt {
	    -xml {
		set xml $val
	    }
	    -text {
		set description $val
	    }
	}
    }
    set err [jlib::wrapper:createtag error \
		-vars [list code $code] \
		-chdata $description]
    if {$xml == ""} {
	return [list $err]
    } else {
	return [list $xml $err]
    }
}

##########################################################################

proc stanzaerror::xmpp_error {type condition args} {
    variable NS
    variable legacy_error_codes

    set subtags [list [jlib::wrapper:createtag $condition \
			   -vars [list xmlns $NS(stanzas)]]]
    set xml ""
    foreach {opt val} $args {
	switch -- $opt {
	    -xml {
		set xml $val
	    }
	    -text {
		lappend subtags [jlib::wrapper:createtag text \
				     -vars [list xmlns $NS(stanzas)] \
				     -chdata $val]
	    }
	    -application-specific {
		lappend subtags $val
	    }
	}
    }
    set vars [list type $type]
    if {[info exists legacy_error_codes($condition)] && \
	    $legacy_error_codes($condition)} {
	lappend vars code $legacy_error_codes($condition)
    }
    set err [jlib::wrapper:createtag error \
		-vars $vars \
		-subtags $subtags]
    if {$xml == ""} {
	return [list $err]
    } else {
	return [list $xml $err]
    }
}

##########################################################################

