1# 2# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> 3# 4# $Header: /home/sdevrieze/svn-migration/coccinella-cvsbackup/coccinella/bin/macosx/PowerMacintosh/tls1.50/tls.tcl,v 1.1 2004-04-28 13:59:29 matben Exp $ 5# 6namespace eval tls { 7 variable logcmd tclLog 8 variable debug 0 9 10 # Default flags passed to tls::import 11 variable defaults {} 12 13 # Maps UID to Server Socket 14 variable srvmap 15 variable srvuid 0 16} 17# 18# Backwards compatibility, also used to set the default 19# context options 20# 21proc tls::init {args} { 22 variable defaults 23 24 set defaults $args 25} 26# 27# Helper function - behaves exactly as the native socket command. 28# 29proc tls::socket {args} { 30 set idx [lsearch $args -server] 31 if {$idx != -1} { 32 set server 1 33 set callback [lindex $args [expr {$idx+1}]] 34 set args [lreplace $args $idx [expr {$idx+1}]] 35 36 set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" 37 set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1" 38 } else { 39 set server 0 40 41 set usage "wrong # args: should be \"tls::socket ?options? host port\"" 42 set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1" 43 } 44 set argc [llength $args] 45 set sopts {} 46 set iopts [concat [list -server $server] ${tls::defaults}] ;# Import options 47 48 for {set idx 0} {$idx < $argc} {incr idx} { 49 set arg [lindex $args $idx] 50 switch -glob -- $server,$arg { 51 0,-async {lappend sopts $arg} 52 0,-myaddr - 53 *,-myport {lappend sopts $arg [lindex $args [incr idx]]} 54 *,-cadir - 55 *,-cafile - 56 *,-certfile - 57 *,-cipher - 58 *,-command - 59 *,-keyfile - 60 *,-password - 61 *,-request - 62 *,-require - 63 *,-ssl2 - 64 *,-ssl3 - 65 *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} 66 -* {return -code error "bad option \"$arg\": must be one of $options"} 67 default {break} 68 } 69 } 70 if {$server} { 71 if {($idx + 1) != $argc} { 72 return -code error $usage 73 } 74 set uid [incr ::tls::srvuid] 75 76 set port [lindex $args [expr {$argc-1}]] 77 lappend sopts $port 78 #set sopts [linsert $sopts 0 -server $callback] 79 set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] 80 #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] 81 } else { 82 if {($idx + 2) != $argc} { 83 return -code error $usage 84 } 85 set host [lindex $args [expr {$argc-2}]] 86 set port [lindex $args [expr {$argc-1}]] 87 lappend sopts $host $port 88 } 89 # 90 # Create TCP/IP socket 91 # 92 set chan [eval ::socket $sopts] 93 if {!$server && [catch { 94 # 95 # Push SSL layer onto socket 96 # 97 eval [list tls::import] $chan $iopts 98 } err]} { 99 set info ${::errorInfo} 100 catch {close $chan} 101 return -code error -errorinfo $info $err 102 } 103 return $chan 104} 105 106# tls::_accept -- 107# 108# This is the actual accept that TLS sockets use, which then calls 109# the callback registered by tls::socket. 110# 111# Arguments: 112# iopts tls::import opts 113# callback server callback to invoke 114# chan socket channel to accept/deny 115# ipaddr calling IP address 116# port calling port 117# 118# Results: 119# Returns an error if the callback throws one. 120# 121proc tls::_accept { iopts callback chan ipaddr port } { 122 log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] 123 124 set chan [eval [list tls::import $chan] $iopts] 125 126 lappend callback $chan $ipaddr $port 127 if {[catch { 128 uplevel #0 $callback 129 } err]} { 130 log 1 "tls::_accept error: ${::errorInfo}" 131 close $chan 132 error $err $::errorInfo $::errorCode 133 } else { 134 log 2 "tls::_accept - called \"$callback\" succeeded" 135 } 136} 137# 138# Sample callback for hooking: - 139# 140# error 141# verify 142# info 143# 144proc tls::callback {option args} { 145 variable debug 146 147 #log 2 [concat $option $args] 148 149 switch -- $option { 150 "error" { 151 foreach {chan msg} $args break 152 153 log 0 "TLS/$chan: error: $msg" 154 } 155 "verify" { 156 # poor man's lassign 157 foreach {chan depth cert rc err} $args break 158 159 array set c $cert 160 161 if {$rc != "1"} { 162 log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" 163 } else { 164 log 2 "TLS/$chan: verify/$depth: $c(subject)" 165 } 166 if {$debug > 0} { 167 return 1; # FORCE OK 168 } else { 169 return $rc 170 } 171 } 172 "info" { 173 # poor man's lassign 174 foreach {chan major minor state msg} $args break 175 176 if {$msg != ""} { 177 append state ": $msg" 178 } 179 # For tracing 180 upvar #0 tls::$chan cb 181 set cb($major) $minor 182 183 log 2 "TLS/$chan: $major/$minor: $state" 184 } 185 default { 186 return -code error "bad option \"$option\":\ 187 must be one of error, info, or verify" 188 } 189 } 190} 191 192proc tls::xhandshake {chan} { 193 upvar #0 tls::$chan cb 194 195 if {[info exists cb(handshake)] && \ 196 $cb(handshake) == "done"} { 197 return 1 198 } 199 while {1} { 200 vwait tls::${chan}(handshake) 201 if {![info exists cb(handshake)]} { 202 return 0 203 } 204 if {$cb(handshake) == "done"} { 205 return 1 206 } 207 } 208} 209 210proc tls::password {} { 211 log 0 "TLS/Password: did you forget to set your passwd!" 212 # Return the worlds best kept secret password. 213 return "secret" 214} 215 216proc tls::log {level msg} { 217 variable debug 218 variable logcmd 219 220 if {$level > $debug || $logcmd == ""} { 221 return 222 } 223 set cmd $logcmd 224 lappend cmd $msg 225 uplevel #0 $cmd 226} 227