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