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