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