@@ -1,9 +1,9 @@ # # Copyright (C) 1997-2000 Matt Newman # -# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.2 2000/01/20 01:51:05 aborr Exp $ +# $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.tcl,v 1.3 2000/07/27 01:58:18 hobbs Exp $ # namespace eval tls { variable logcmd tclLog variable debug 0 @@ -46,26 +46,26 @@ set iopts [concat [list -server $server] ${tls::defaults}] ;# Import options for {set idx 0} {$idx < $argc} {incr idx} { set arg [lindex $args $idx] switch -glob -- $server,$arg { - 0,-myport - - *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]} - 0,-async {lappend sopts $arg} - *,-cipher - - *,-cadir - - *,-cafile - - *,-certfile - - *,-keyfile - - *,-command - - *,-request - - *,-require - - *,-ssl2 - - *,-ssl3 - - *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} - -* {return -code error "bad option \"$arg\": must be one of $options"} - default {break} + 0,-myport - + *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]} + 0,-async {lappend sopts $arg} + *,-cipher - + *,-cadir - + *,-cafile - + *,-certfile - + *,-keyfile - + *,-command - + *,-request - + *,-require - + *,-ssl2 - + *,-ssl3 - + *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} + -* {return -code error "bad option \"$arg\": must be one of $options"} + default {break} } } if {$server} { if {($idx + 1) != $argc} { return -code error $usage @@ -72,10 +72,11 @@ } set uid [incr ::tls::srvuid] set port [lindex $args [expr {$argc-1}]] lappend sopts $port + #set sopts [linsert $sopts 0 -server $callback] set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] } else { if {($idx + 2) != $argc} { return -code error $usage @@ -98,10 +99,26 @@ catch {close $chan} return -code error -errorinfo $info $err } return $chan } + +# tls::_accept -- +# +# This is the actual accept that TLS sockets use, which then calls +# the callback registered by tls::socket. +# +# Arguments: +# iopts tls::import opts +# callback server callback to invoke +# chan socket channel to accept/deny +# ipaddr calling IP address +# port calling port +# +# Results: +# Returns an error if the callback throws one. +# proc tls::_accept { iopts callback chan ipaddr port } { log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] set chan [eval [list tls::import $chan] $iopts] @@ -109,10 +126,11 @@ if {[catch { uplevel #0 $callback } err]} { log 1 "tls::_accept error: ${::errorInfo}" close $chan + error $err $::errorInfo $::errorCode } else { log 2 "tls::_accept - called \"$callback\" succeeded" } } # @@ -127,49 +145,50 @@ variable debug #log 2 [concat $option $args] switch -- $option { - "error" { - foreach {chan msg} $args break - - log 0 "TLS/$chan: error: $msg" - } - "verify" { - # poor man's lassign - foreach {chan depth cert rc err} $args break - - array set c $cert - - if {$rc != "1"} { - log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" - } else { - log 2 "TLS/$chan: verify/$depth: $c(subject)" - } - if {$debug > 0} { - return 1; # FORCE OK - } else { - return $rc - } - } - "info" { - # poor man's lassign - foreach {chan major minor state msg} $args break - - if {$msg != ""} { - append state ": $msg" - } - # For tracing - upvar #0 tls::$chan cb - set cb($major) $minor - - log 2 "TLS/$chan: $major/$minor: $state" - } - default { - return -code error "bad option \"$option\": must be one of error, info, or verify" - } - };#sw + "error" { + foreach {chan msg} $args break + + log 0 "TLS/$chan: error: $msg" + } + "verify" { + # poor man's lassign + foreach {chan depth cert rc err} $args break + + array set c $cert + + if {$rc != "1"} { + log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" + } else { + log 2 "TLS/$chan: verify/$depth: $c(subject)" + } + if {$debug > 0} { + return 1; # FORCE OK + } else { + return $rc + } + } + "info" { + # poor man's lassign + foreach {chan major minor state msg} $args break + + if {$msg != ""} { + append state ": $msg" + } + # For tracing + upvar #0 tls::$chan cb + set cb($major) $minor + + log 2 "TLS/$chan: $major/$minor: $state" + } + default { + return -code error "bad option \"$option\":\ + must be one of error, info, or verify" + } + } } proc tls::xhandshake {chan} { upvar #0 tls::$chan cb