1# 2# Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com> 3# 4# $Header: /cvsroot/tls/tls/tls.tcl,v 1.12 2010/07/27 17:15:47 hobbs2 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 # Over-ride this if you are using a different socket command 18 variable socketCmd 19 if {![info exists socketCmd]} { 20 set socketCmd [info command ::socket] 21 } 22} 23 24proc tls::initlib {dir dll} { 25 # Package index cd's into the package directory for loading. 26 # Irrelevant to unixoids, but for Windows this enables the OS to find 27 # the dependent DLL's in the CWD, where they may be. 28 set cwd [pwd] 29 catch {cd $dir} 30 if {[string equal $::tcl_platform(platform) "windows"] && 31 ![string equal [lindex [file system $dir] 0] "native"]} { 32 # If it is a wrapped executable running on windows, the openssl 33 # dlls must be copied out of the virtual filesystem to the disk 34 # where Windows will find them when resolving the dependency in 35 # the tls dll. We choose to make them siblings of the executable. 36 package require starkit 37 set dst [file nativename [file dirname $starkit::topdir]] 38 foreach sdll [glob -nocomplain -directory $dir -tails *eay32.dll] { 39 catch {file delete -force $dst/$sdll} 40 catch {file copy -force $dir/$sdll $dst/$sdll} 41 } 42 } 43 set res [catch {uplevel #0 [list load [file join [pwd] $dll]]} err] 44 catch {cd $cwd} 45 if {$res} { 46 namespace eval [namespace parent] {namespace delete tls} 47 return -code $res $err 48 } 49 rename tls::initlib {} 50} 51 52# 53# Backwards compatibility, also used to set the default 54# context options 55# 56proc tls::init {args} { 57 variable defaults 58 59 set defaults $args 60} 61# 62# Helper function - behaves exactly as the native socket command. 63# 64proc tls::socket {args} { 65 variable socketCmd 66 variable defaults 67 set idx [lsearch $args -server] 68 if {$idx != -1} { 69 set server 1 70 set callback [lindex $args [expr {$idx+1}]] 71 set args [lreplace $args $idx [expr {$idx+1}]] 72 73 set usage "wrong # args: should be \"tls::socket -server command ?options? port\"" 74 set options "-cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -password, -request, -require, -ssl2, -ssl3, or -tls1" 75 } else { 76 set server 0 77 78 set usage "wrong # args: should be \"tls::socket ?options? host port\"" 79 set options "-async, -cadir, -cafile, -certfile, -cipher, -command, -keyfile, -myaddr, -myport, -password, -request, -require, -ssl2, -ssl3, or -tls1" 80 } 81 set argc [llength $args] 82 set sopts {} 83 set iopts [concat [list -server $server] $defaults] ;# Import options 84 85 for {set idx 0} {$idx < $argc} {incr idx} { 86 set arg [lindex $args $idx] 87 switch -glob -- $server,$arg { 88 0,-async {lappend sopts $arg} 89 0,-myport - 90 *,-type - 91 *,-myaddr {lappend sopts $arg [lindex $args [incr idx]]} 92 *,-cadir - 93 *,-cafile - 94 *,-certfile - 95 *,-cipher - 96 *,-command - 97 *,-keyfile - 98 *,-password - 99 *,-request - 100 *,-require - 101 *,-ssl2 - 102 *,-ssl3 - 103 *,-tls1 {lappend iopts $arg [lindex $args [incr idx]]} 104 -* {return -code error "bad option \"$arg\": must be one of $options"} 105 default {break} 106 } 107 } 108 if {$server} { 109 if {($idx + 1) != $argc} { 110 return -code error $usage 111 } 112 set uid [incr ::tls::srvuid] 113 114 set port [lindex $args [expr {$argc-1}]] 115 lappend sopts $port 116 #set sopts [linsert $sopts 0 -server $callback] 117 set sopts [linsert $sopts 0 -server [list tls::_accept $iopts $callback]] 118 #set sopts [linsert $sopts 0 -server [list tls::_accept $uid $callback]] 119 } else { 120 if {($idx + 2) != $argc} { 121 return -code error $usage 122 } 123 set host [lindex $args [expr {$argc-2}]] 124 set port [lindex $args [expr {$argc-1}]] 125 lappend sopts $host $port 126 } 127 # 128 # Create TCP/IP socket 129 # 130 set chan [eval $socketCmd $sopts] 131 if {!$server && [catch { 132 # 133 # Push SSL layer onto socket 134 # 135 eval [list tls::import] $chan $iopts 136 } err]} { 137 set info ${::errorInfo} 138 catch {close $chan} 139 return -code error -errorinfo $info $err 140 } 141 return $chan 142} 143 144# tls::_accept -- 145# 146# This is the actual accept that TLS sockets use, which then calls 147# the callback registered by tls::socket. 148# 149# Arguments: 150# iopts tls::import opts 151# callback server callback to invoke 152# chan socket channel to accept/deny 153# ipaddr calling IP address 154# port calling port 155# 156# Results: 157# Returns an error if the callback throws one. 158# 159proc tls::_accept { iopts callback chan ipaddr port } { 160 log 2 [list tls::_accept $iopts $callback $chan $ipaddr $port] 161 162 set chan [eval [list tls::import $chan] $iopts] 163 164 lappend callback $chan $ipaddr $port 165 if {[catch { 166 uplevel #0 $callback 167 } err]} { 168 log 1 "tls::_accept error: ${::errorInfo}" 169 close $chan 170 error $err $::errorInfo $::errorCode 171 } else { 172 log 2 "tls::_accept - called \"$callback\" succeeded" 173 } 174} 175# 176# Sample callback for hooking: - 177# 178# error 179# verify 180# info 181# 182proc tls::callback {option args} { 183 variable debug 184 185 #log 2 [concat $option $args] 186 187 switch -- $option { 188 "error" { 189 foreach {chan msg} $args break 190 191 log 0 "TLS/$chan: error: $msg" 192 } 193 "verify" { 194 # poor man's lassign 195 foreach {chan depth cert rc err} $args break 196 197 array set c $cert 198 199 if {$rc != "1"} { 200 log 1 "TLS/$chan: verify/$depth: Bad Cert: $err (rc = $rc)" 201 } else { 202 log 2 "TLS/$chan: verify/$depth: $c(subject)" 203 } 204 if {$debug > 0} { 205 return 1; # FORCE OK 206 } else { 207 return $rc 208 } 209 } 210 "info" { 211 # poor man's lassign 212 foreach {chan major minor state msg} $args break 213 214 if {$msg != ""} { 215 append state ": $msg" 216 } 217 # For tracing 218 upvar #0 tls::$chan cb 219 set cb($major) $minor 220 221 log 2 "TLS/$chan: $major/$minor: $state" 222 } 223 default { 224 return -code error "bad option \"$option\":\ 225 must be one of error, info, or verify" 226 } 227 } 228} 229 230proc tls::xhandshake {chan} { 231 upvar #0 tls::$chan cb 232 233 if {[info exists cb(handshake)] && \ 234 $cb(handshake) == "done"} { 235 return 1 236 } 237 while {1} { 238 vwait tls::${chan}(handshake) 239 if {![info exists cb(handshake)]} { 240 return 0 241 } 242 if {$cb(handshake) == "done"} { 243 return 1 244 } 245 } 246} 247 248proc tls::password {} { 249 log 0 "TLS/Password: did you forget to set your passwd!" 250 # Return the worlds best kept secret password. 251 return "secret" 252} 253 254proc tls::log {level msg} { 255 variable debug 256 variable logcmd 257 258 if {$level > $debug || $logcmd == ""} { 259 return 260 } 261 set cmd $logcmd 262 lappend cmd $msg 263 uplevel #0 $cmd 264} 265 266