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