#  jlibtls.tcl --
#  
#      This file is part of the jabberlib. It provides support for the
#      tls network socket security layer.
#      
#  Copyright (c) 2005 Sergei Golovan <sgolovan@nes.ru>
#  Based on jlibtls by Mats Bengtsson
#  
# $Id: jlibtls.tcl 1488 2008-08-25 10:14:35Z sergei $
#
# SYNOPSIS
#   jlibtls::new connid args
#	creates auth token
#	args: -certfile    certfile
#	      -cacertstore cacertstore
#	      -keyfile     keyfile
#	      -command     callback
#
#   token configure args
#	configures token parameters
#	args: the same as in jlibtls::new
#
#   token starttls args
#	starts STARTTLS procedure
#	args: the same as in jlibtls::new
#
#   token free
#	frees token resourses

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

package require tls 1.4
package require namespaces 1.0

package provide jlibtls 1.0

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

namespace eval jlibtls {
    variable uid 0
}

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

proc jlibtls::new {connid args} {
    variable uid

    set token [namespace current]::[incr uid]
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::new $connid) $token"

    set state(-connid) $connid
    catch { unset state(-starttls) }
    catch { unset state(-required) }

    proc $token {cmd args} \
	"eval {[namespace current]::\$cmd} {$token} \$args"

    eval [list configure $token] $args

    jlib::register_xmlns $state(-connid) $::NS(tls) \
	[namespace code [list parse $token]]

    return $token
}

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

proc jlibtls::free {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::free $token)"

    jlib::unregister_xmlns $state(-connid) $::NS(tls)

    catch { unset state }
    catch { rename $token "" }
}

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

proc jlibtls::configure {token args} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::configure $token)"

    foreach {key val} $args {
	switch -- $key {
	    -cacertstore {
		if {$val != ""} {
		    if {[file isdirectory $val]} {
			set state(-cadir) $val
		    } else {
			set state(-cafile) $val
		    }
		}
	    }
	    -certfile -
	    -keyfile -
	    -command {
		set state($key) $val
	    }
	    default {
		return -code error "Illegal option \"$key\""
	    }
	}
    }
}

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

proc jlibtls::parse {token xmldata} {
    variable $token
    upvar 0 $token state

    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children

    switch -- $tag {
	starttls {
	    set state(-starttls) 1
	    foreach ch $children {
		jlib::wrapper:splitxml $ch tag1 vars1 isempty1 cdata1 children1
		if {$tag1 == "required"} {
		    set state(-required) 1
		}
	    }
	}
	proceed {
	    proceed $token
	}
	failure {
	    failure $token $children
	}
    }
}

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

proc jlibtls::starttls {token args} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::start $token)"

    eval [list configure $token] $args

    jlib::trace_stream_features $state(-connid) \
	[namespace code [list tls_continue $token]]
}

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

proc jlibtls::tls_continue {token} {
    variable $token
    upvar 0 $token state
    
    ::LOG "(jlibtls::tls_continue $token)"

    if {![info exists state(-starttls)]} {
	set err [stanzaerror::error modify not-acceptable -text \
		     [::msgcat::mc \
			  "Server haven't provided STARTTLS feature"]]
	finish $token ERR [concat modify $err]
	return
    }

    set data [jlib::wrapper:createtag starttls -vars [list xmlns $::NS(tls)]]
    
    jlib::outmsg [jlib::wrapper:createxml $data] -connection $state(-connid)
}

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

proc jlibtls::failure {token children} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::failure $token)"

    set error [lindex $children 0]
    if {$error == ""} {
	set err [stanzaerror::error modify undefined-condition \
		     -text [::msgcat::mc "STARTTLS failed"]]
    } else {
	jlib::wrapper:splitxml $error tag vars empty cdata children
	set err [stanzaerror::error modify $tag]
    }
    finish $token ERR [concat modify $err]
}

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

proc jlibtls::proceed {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::proceed $token)"

    set args {}
    foreach key {-cadir -cafile -certfile -keyfile} {
	if {[info exists state($key)] && $state($key) != ""} {
	    lappend args $key $state($key)
	}
    }

    if {[catch {
	     eval [list jlib::transport::tcp::to_tls $state(-connid)] $args
         } msg]} {
	set err [stanzaerror::error modify undefined-condition -text $msg]
	finish $token ERR [concat modify $err]
	return
    }

    jlib::reset $state(-connid)

    jlib::start_stream [jlib::connection_server $state(-connid)] \
		       -xml:lang [jlib::get_lang] -version "1.0" \
		       -connection $state(-connid)
    finish $token OK {}
}

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

proc jlibtls::finish {token res xmldata} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibtls::finish $token) res"

    if {$res != "OK"} {
	jlib::client status [::msgcat::mc "STARTTLS failed"]
    } else {
	jlib::client status [::msgcat::mc "STARTTLS successful"]
    }
    if {[info exists state(-command)]} {
	uplevel #0 $state(-command) [list $res $xmldata]
    }
}

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

