1 # server-rtsp.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1997-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31
32 import TCP SessionCatalog Application RTSPWorker SDPParser
33
34 #Class RTSPServerManager -superclass TCP/Server
35
36 #RTSPServerManager instproc create_channel chan {
37 # return [new RTSPServer $chan]
38 #}
39
40 #RTSPServerManager public init port {
41 # $self next
42 # $self open $port
43 #}
44
45
46
47 # Implements the functionality of an archive server which uses RTSP for communication with the client. Currently, this code is part of the arms application. We are concentrating on developing a soft state protocol with RTSP's functionality (SSAC) so this code will not be under development.
48 # Status: Alpha
49 # Needs a lot of cleaning up, error trapping. I'm suspicious of the efficacy of teardown.
50
51 #<FIXME should not be a subclass of application!>
52 Class RTSPServer -superclass { Application TCP }
53
54 global response_code_
55 global version
56
57 set response_code_(200) "OK"
58 set response_code_(400) "Bad request"
59 set response_code_(403) "Forbidden"
60 set response_code_(404) "Not found"
61 set response_code_(405) "Method Not Allowed"
62 set response_code_(451) "Parameter not understood"
63 set response_code_(500) "Internal server error"
64
65 set version "RTSP/1.0"
66
67
68 #FIXME "self next player"?
69 RTSPServer instproc init { } {
70 puts "Making new server"
71 $self next player
72 puts "Made new server"
73 RTSPServer set instance_ $self
74 $self set buffer_ ""
75 }
76
77
78 RTSPServer instproc open chan {
79 #puts "Making new server"
80 #$self next player
81 #puts "Made new server"
82 #RTSPServer set instance_ $self
83 #$self set buffer_ ""
84
85 $self next $chan
86
87 #I don't think this is necessary, can remove from_
88 set peer [fconfigure $chan -peername]
89 puts stderr "PEER $peer"
90 $self set from_ [lindex $peer 0]
91
92 }
93
94 #FIXME
95 RTSPServer instproc instance {} {
96 return [$self set instance_]
97 }
98
99 #
100 # Called from TCP module when we receive data on our socket, which
101 # consists of rtsp commands from the server that we have connected to.
102 # We receive the data a line at a time.
103 #
104 RTSPServer instproc recv s {
105 $self instvar buffer_ parser_
106 set buffer_ "$buffer_\n$s"
107 #
108 # Check for blank line then hand to parser.
109 #
110 if { [string trim $s] == "" } {
111 set m [string trim $buffer_]
112 set buffer_ ""
113 if { $m == "" } {
114 return
115 }
116
117 #
118 # send reponse followed by a blank line
119 #
120 set response [$self recv_message $m]
121 $self send "$response\n"
122 }
123 }
124
125 RTSPServer instproc recv_message msg {
126
127 $self instvar response_
128
129 if [catch {$self parse $msg} error] {
130 set response_(code) 400
131 set response_(tokens) {}
132 puts "Error parsing"
133 }
134
135 if [catch {$self state-machine $msg} error] {
136 set response_(code) 500
137 set response_(tokens) {}
138 puts "Server State-machine error"
139 }
140
141 if {! [info exists response_(tokens)] } {
142 set response_(tokens) {}
143 }
144 if {! [info exists response_(body)] } {
145 set response_(body) ""
146 }
147 set resp [$self build_response $response_(code) $response_(tokens) $response_(body)]
148 set response_(tokens) {}
149 set response_(body) ""
150
151 return $resp
152 }
153
154 RTSPServer instproc build_response {code extras body} {
155 global version response_code_
156 $self instvar params_
157
158 set myresponse "$version $code $response_code_($code)"
159 if [info exists params_(CSeq)] {
160 set myresponse "$myresponse\nCSeq: $params_(CSeq)"
161 }
162 foreach token $extras {
163 set myresponse "$myresponse\n$token: $params_($token)"
164 }
165 if {$body != ""} {
166 set myresponse "$myresponse\n$body\n\n"
167 } else {
168 set myresponse "$myresponse\n\n"
169 }
170 #puts "----START RESPONSE----\n$myresponse\n----END RESPONSE----"
171
172 return $myresponse
173 }
174
175
176
177 RTSPServer instproc parse {msg} {
178 $self instvar params_
179
180 if [info exists params_] {
181 unset params_
182 }
183
184 set lines [split $msg "\n"]
185 set request_line [split [lindex $lines 0]]
186 set params_(method) [lindex $request_line 0]
187 set params_(uri) [lindex $request_line 1]
188 set params_(rtsp_version) [lindex $request_line 2]
189
190 set len [llength $lines]
191
192 for {set n 1} {$n < $len} { incr n} {
193 regexp {([a-zA-Z]+)(: )(.+)} [lindex $lines $n] all token mid rest
194 set rest [string trim $rest]
195 if [info exists token] {
196 set params_($token) $rest
197 #puts "Tokens: $token $rest"
198
199 }
200 }
201 }
202
203 RTSPServer instproc call-new-worker {} {
204 $self instvar params_ workers_ response_ from_
205
206 if { ! [info exists params_(Session)] } {
207 set new_num [$self generate-session-id]
208 set params_(Session) $new_num
209 set workers_($new_num) [new RTSPWorker $new_num $from_]
210 set paramlist [array get params_]
211 set response_(code) [$workers_($new_num) recv $paramlist]
212 } else {
213 # error check here
214 set param_list [array get params_]
215 set response_(code) [$workers_($params_(Session)) recv $param_list]
216 puts "Worker returned $response_(code)"
217 }
218 }
219
220 RTSPServer instproc call-worker {} {
221 $self instvar params_ workers_ response_
222
223 if { ! [info exists params_(Session)] } {
224 puts "No Session param"
225 # error
226 } else {
227 # error check here
228 set param_list [array get params_]
229 set response_(code) [$workers_($params_(Session)) recv $param_list]
230 puts "Worker returned $response_(code)"
231 }
232
233 }
234
235 RTSPServer instproc state-machine {msg} {
236 $self instvar params_ response_ cur_state_ workers_
237
238 switch $params_(method) {
239 OPTIONS {
240 puts "OPTIONS"
241 set params_(Public) "OPTIONS, PLAY, SETUP, TEARDOWN"
242 set response_(code) 200
243 set response_(tokens) {Public}
244
245 }
246 DESCRIBE {
247 puts "DESCRIBE"
248 set response_(code) 200
249 set response [$self do_describe]
250 if { $response_(code) != 200 } {
251 set response_(tokens) {}
252 return
253 }
254 #$self send_describe $response
255 set params_(Content-Type) "application/sdp"
256 set params_(Content-Length) [string length $response]
257 puts "--DESCRIBE"
258 set response_(tokens) {Content-Type Content-Length}
259 set response_(body) $response
260
261 }
262 SETUP {
263 if {[info exists params_(Session)]} {
264 $self call-worker
265 } else {
266 $self call-new-worker
267 }
268 if {$response_(code) < 202} {
269 set temp $params_(Session)
270 puts "temp $temp"
271 set cur_state_($temp) ready
272 puts "ready"
273 set response_(tokens) {Session Transport}
274 }
275 puts "Done"
276 }
277 TEARDOWN {
278 # FIX THIS
279 puts "TEARDOWN"
280 delete $workers_($params_(Session))
281 set cur_state_($params_(Session)) done
282 #FIXME
283 #$tcpobj_ reset_net
284 $self shutdown
285 # delete self?
286 }
287 PLAY {
288 # Need to check for ready or playing?
289 $self call-worker
290 if {$response_(code) < 202} {
291 set cur_state_($params_(Session)) playing
292 set response_(tokens) {}
293 }
294 }
295 PAUSE {
296 # Need to check for ready or playing?
297 $self call-worker
298 if {$response_(code) < 202} {
299 set cur_state_($params_(Session)) ready
300 set response_(tokens) {}
301 }
302 }
303
304 }
305 }
306
307 RTSPServer instproc generate-session-id {} {
308 $self instvar cur_state_
309
310 # FIX THIS to generate random id
311
312 set num [array size cur_state_]
313 return [incr num]
314
315 }
316
317 RTSPServer instproc do_teardown {} {
318 $self instvar params_
319
320
321
322 }
323
324
325 RTSPServer instproc do_describe {} {
326 $self instvar params_
327
328 set start "max"
329 set end "min"
330 set response ""
331 set resptail ""
332
333 regexp {(rtsp://[a-z\.\:0-9]+)/(.+)} $params_(uri) junk junk2 filename
334
335 $self instvar response_
336 if ![info exists filename] {
337 # Return not found (code 404)
338 set response_(code) 404
339 #response: parameter not understood
340 puts "malformed url ($params_(uri)) - returning code 404"
341 return
342 }
343
344 puts "$filename"
345
346 set filename2 $filename.ctg
347
348 if ![file readable $filename2] {
349 # Return not found (code 404)
350 set response_(code) 404
351 #response: parameter not understood
352 puts "$filename2 not readable - returning code 404"
353 return
354 }
355
356 set catalog [new SessionCatalog]
357
358 if { [catch {$catalog open $filename2} error] } {
359 set response_(code) 451
360 #response: parameter not understood
361 puts "Couldn't open $filename2"
362 return
363 }
364 if { [catch {$catalog read} error] } {
365 set response_(code) 500
366 #response: internal server error
367 puts "Couldn't read $filename2"
368 return
369 }
370 set sdp [$catalog get_sdp]
371 if {$sdp != ""} {
372 set p [new SDPParser]
373 set announcement [$p parse $sdp]
374
375 set response "v=[$announcement field_value v]"
376 set response "$response\no=[$announcement field_value o]"
377 set response "$response\ns=[$announcement field_value s]"
378 set response "$response\ni=[$announcement field_value i]"
379
380
381 } else {
382 set response "v=0"
383 set response "$response\no="
384 set response "$response\ns=$filename"
385 set response "$response\ni="
386
387 }
388
389 set response "$response\nu=$params_(uri)"
390 foreach id [$catalog info streams] {
391 lappend sessions([$catalog info session $id]) $id
392 }
393 set file [new ArchiveFile]
394 foreach s [array names sessions] {
395 foreach id $sessions($s) {
396 set my_datafile [$catalog info datafile $id]
397 set my_indexfile [$catalog info indexfile $id]
398 if [catch {$file open $my_datafile} error] {
399 set response_(code) 500
400 #response: internal server error
401 puts "Couldn't open $my_datafile"
402 delete $catalog
403 delete $file
404 return
405 }
406
407 if [catch {$file header data_hdr} error] {
408 set response_(code) 500
409 #response: internal server error
410 puts "Wrong header format for $my_datafile"
411 delete $catalog
412 delete $file
413 return
414 }
415 $file close
416 if [catch {$file open $my_indexfile} error] {
417 set response_(code) 500
418 #response: internal server error
419 puts "Couldn't open $my_indexfile"
420 delete $catalog
421 delete $file
422 return
423 }
424
425 if [catch {$file header index_hdr} error] {
426 set response_(code) 500
427 #response: internal server error
428 puts "Wrong header format $my_indexfile"
429 delete $catalog
430 delete $file
431 return
432 }
433
434 $file close
435
436
437 if { $data_hdr(protocol)!=$index_hdr(protocol) } {
438 set response_(code) 500
439 #response: internal server error
440 puts "Protocol fields do not\
441 match in data and index files"
442 delete $catalog
443 delete $file
444 return
445 }
446
447 if { $data_hdr(media)!=$index_hdr(media) } {
448 set response_(code) 500
449
450 #response: internal server error
451 puts "Media fields do not\
452 match in $my_datafile and $my_indexfile"
453 delete $catalog
454 delete $file
455 return
456 }
457
458 if { $data_hdr(cname)!=$index_hdr(cname) } {
459 set response_(code) 500
460 #response: internal server error
461 puts "Cname fields don't match \
462 in $my_datafile and $my_indexfile"
463 delete $catalog
464 delete $file
465 return
466 }
467
468 if { $data_hdr(name)!=$index_hdr(name) } {
469 set response_(code) 500
470 #response: internal server error
471 puts "Name fields don't match in \
472 $my_datafile and $my_indexfile"
473 delete $catalog
474 delete $file
475 return
476 }
477
478 #$file close
479
480 #puts "This far"
481
482 #Need to add a check for start=0
483
484 if {$data_hdr(media)!="mediaboard"} {
485 if {$start == "max"} {
486 set start $data_hdr(start)
487 set end $data_hdr(end)
488
489 } else {
490
491 if {$data_hdr(start) < $start} {
492 set start $data_hdr(start)
493
494
495 }
496 if {$data_hdr(end) > $end} {
497 set end $data_hdr(end)
498
499 }
500
501 }
502 }
503
504
505 }
506
507 set resptail "$resptail\nm=$data_hdr(media) 0 RTP/AVP 0"
508 set resptail "$resptail\nc=IN IP4 $params_(uri)/$s"
509 #set resptail "$resptail\na=control:rtsp:$params_(uri)/$s"
510
511
512 }
513
514
515 set wholeresponse "$response\nt=$start $end$resptail"
516
517
518 delete $catalog
519
520 return $wholeresponse
521 }
522
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.