1# -*- tcl -*-
2# Dialog - Dialog Demon (Server, or Client)
3# Copyright (c) 2004, Andreas Kupries <andreas_kupries@users.sourceforge.net>
4
5puts "- dialog (coserv-based)"
6
7# ### ### ### ######### ######### #########
8## Commands on top of a plain comm server.
9## Assumes that the comm server environment
10## is present. Provides set up and execution
11## of a fixed linear dialog, done from the
12# perspective of a server application.
13
14# ### ### ### ######### ######### #########
15## Load "comm" into the master.
16
17namespace eval ::dialog {
18    variable dtrace    {}
19}
20
21# ### ### ### ######### ######### #########
22## Start a new dialog server.
23
24proc ::dialog::setup {type cookie {ssl 0}} {
25    variable id
26    variable port
27
28    switch -- $type {
29	server  {set server 1}
30	client  {set server 0}
31	default {return -code error "Bad dialog type \"$type\", expected server, or client"}
32    }
33
34    set id [::coserv::start "$type: $cookie"]
35    ::coserv::run $id {
36	set responses {}
37	set strace    {}
38	set received  {}
39	set conn      {}
40	set ilog      {}
41
42	proc Log {text} {
43	    global ilog ; lappend ilog $text
44	}
45	proc Strace {text} {
46	    global strace ; lappend strace $text
47	}
48	proc Exit {sock reason} {
49	    Strace $reason
50	    Log    [list $reason $sock]
51	    close  $sock
52	    Done
53	}
54	proc Done {} {
55	    global main strace ilog
56	    comm::comm send $main [list dialog::done [list $strace $ilog]]
57	    return
58	}
59	proc ClearTraces {} {
60	    global strace ; set strace {}
61	    global ilog   ; set ilog   {}
62	    return
63	}
64	proc Step {sock} {
65	    global responses trace
66
67	    if {![llength $responses]} {
68		Exit $sock empty
69		return
70	    }
71
72	    set now       [lindex $responses 0]
73	    set responses [lrange $responses 1 end]
74
75	    Log  [list ** $sock $now]
76	    eval [linsert $now end $sock]
77	    return
78	}
79
80	# Step commands ...
81
82	proc .Crlf {sock} {
83	    Strace crlf
84	    Log crlf
85	    fconfigure $sock -translation crlf
86	    Step $sock
87	    return
88	}
89	proc .Binary {sock} {
90	    Strace bin
91	    Log binary
92	    fconfigure $sock -translation binary
93	    Step $sock
94	    return
95	}
96	proc .HaltKeep {sock} {
97	    Log halt.keep
98	    Done
99	    global responses
100	    set    responses {}
101	    # No further stepping.
102	    # This keeps the socket open.
103	    # Needs external reset/cleanup
104	    return
105	}
106	proc .Send {line sock} {
107	    Strace [list >> $line]
108	    Log    [list >> $line]
109
110	    if {[catch {
111		puts  $sock $line
112		flush $sock
113	    } msg]} {
114		Exit $sock broken
115		return
116	    }
117	    Step $sock
118	    return
119	}
120	proc .Geval {script sock} {
121	    Log geval
122	    uplevel #0 $script
123	    Step $sock
124	    return
125	}
126	proc .Eval {script sock} {
127	    Log eval
128	    eval $script
129	    Step $sock
130	    return
131	}
132	proc .SendGvar {vname sock} {
133	    upvar #0 $vname line
134	    .Send $line $sock
135	    return
136	}
137	proc .Receive {sock} {
138	    set aid     [after 10000 [list Timeout    $sock]]
139	    fileevent $sock readable [list Input $aid $sock]
140	    # No "Step" here. Comes through input.
141	    Log "   Waiting    \[$aid\]"
142	    return
143	}
144	proc Input {aid sock} {
145	    global received
146	    if {[eof $sock]} {
147		# Clean the timer up
148		after cancel $aid
149		Exit $sock close
150		return
151	    }
152	    if {[gets $sock line] < 0} {
153		Log "   **|////|**"
154		return
155	    }
156
157	    Log "-- -v-"
158	    Log "   Events off \[$aid, $sock\]"
159	    fileevent    $sock readable {}
160	    after cancel $aid
161
162	    Strace [list << $line]
163	    Log    [list << $line]
164	    lappend received $line
165
166	    # Now we can step further
167	    Step $sock
168	    return
169	}
170	proc Timeout {sock} {
171	    Exit $sock timeout
172	    return
173	}
174	proc Accept {sock host port} {
175	    fconfigure $sock -blocking 0
176	    ClearTraces
177	    Step $sock
178	    return
179	}
180
181	proc Server {} {
182	    global port
183	    # Start listener for dialog
184	    set listener [socket -server Accept 0]
185	    set port     [lindex [fconfigure $listener -sockname] 2]
186	    # implied return of <port>
187	}
188
189	proc Client {port} {
190	    global conn
191	    catch {close $conn}
192
193	    set conn [set sock [socket localhost $port]]
194	    fconfigure $sock -blocking 0
195	    ClearTraces
196	    Log [list Client @ $port = $sock]
197	    Log [list Channels $port = [lsort [file channels]]]
198	    Step $sock
199	    return
200	}
201    }
202
203    if {$ssl} {
204	# Replace various commands with tls aware variants
205	coserv::run $id [list set devtools [tcllibPath devtools]]
206	coserv::run $id {
207	    package require tls
208
209	    tls::init \
210		-keyfile  $devtools/transmitter.key \
211		-certfile $devtools/transmitter.crt \
212		-cafile   $devtools/ca.crt \
213		-ssl2 1    \
214		-ssl3 1    \
215		-tls1 0    \
216		-require 1
217
218	    proc Server {} {
219		global port
220		# Start listener for dialog
221		set listener [tls::socket -server Accept 0]
222		set port     [lindex [fconfigure $listener -sockname] 2]
223		# implied return of <port>
224	    }
225
226	    proc Client {port} {
227		global conn
228		catch {close $conn}
229
230		set conn [set sock [tls::socket localhost $port]]
231		fconfigure $sock -blocking 0
232		ClearTraces
233		Log [list Client @ $port = $sock]
234		Log [list Channels $port = [lsort [file channels]]]
235		Step $sock
236		return
237	    }
238	}
239    }
240
241    if {$server} {
242	set port [coserv::run $id {Server}]
243    }
244}
245
246proc ::dialog::runclient {port} {
247    variable id
248    variable dtrace {}
249    coserv::task $id [list Client $port]
250    return
251}
252
253proc ::dialog::dialog_set {response_script} {
254    begin
255    uplevel 1 $response_script
256    end
257    return
258}
259
260proc ::dialog::begin {{cookie {}}} {
261    variable id
262    ::coserv::task $id [list set responses {}]
263    log::log debug "+============================================ $cookie \\\\"
264    return
265}
266
267proc ::dialog::cmd {command} {
268    variable id
269    ::coserv::task $id [list lappend responses $command]
270    return
271}
272
273proc ::dialog::end {} {
274    # This implicitly waits for all preceding commands (which are async) to complete.
275    variable id
276    set responses [::coserv::run $id [list set responses]]
277    ::coserv::run $id {set received {}}
278    log::log debug |\t[join $responses \n|\t]
279    log::log debug +---------------------------------------------
280    return
281}
282
283proc ::dialog::crlf.      {}       {cmd .Crlf}
284proc ::dialog::binary.    {}       {cmd .Binary}
285proc ::dialog::send.      {line}   {cmd [list .Send $line]}
286proc ::dialog::receive.   {}       {cmd .Receive}
287proc ::dialog::respond.   {line}   {receive. ; send. $line}
288proc ::dialog::request.   {line}   {send. $line ; receive.}
289proc ::dialog::halt.keep. {}       {cmd .HaltKeep}
290proc ::dialog::sendgvar.  {vname}  {cmd [list .SendGvar $vname]}
291proc ::dialog::reqgvar.   {vname}  {sendgvar. $vname ; receive.}
292proc ::dialog::geval.     {script} {cmd [list .Geval $script]}
293proc ::dialog::eval.      {script} {cmd [list .Eval  $script]}
294
295proc ::dialog::done {traces} {
296    variable dtrace $traces
297    return
298}
299
300proc ::dialog::waitdone {} {
301    variable dtrace
302
303    # Loop until we have data from the dialog subprocess.
304    # IOW writes which do not create data are ignored.
305    while {![llength $dtrace]} {
306	vwait ::dialog::dtrace
307    }
308
309    foreach {strace ilog} $dtrace break
310    set dtrace {}
311
312    log::log debug  +---------------------------------------------
313    log::log debug  |\t[join $strace \n|\t]
314    log::log debug  +---------------------------------------------
315    log::log debug  /\t[join $ilog \n/\t]
316    log::log debug "+============================================ //"
317    return $strace
318}
319
320proc ::dialog::received {} {
321    # Wait for all preceding commands to complete.
322    variable id
323    set received [::coserv::run $id [list set received]]
324    ::coserv::run $id [list set received {}]
325    return $received
326}
327
328proc ::dialog::listener {} {
329    variable port
330    return $port
331}
332
333proc ::dialog::shutdown {} {
334    variable id
335    variable port
336    variable dtrace
337
338    ::coserv::shutdown $id
339
340    set id     {}
341    set port   {}
342    set dtrace {}
343    return
344}
345
346# ### ### ### ######### ######### #########
347