Check-in [8ab30a71a3]
Not logged in
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Additional corrections to embedded code.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 8ab30a71a35b36fb7644455c37a65ab26db1e9d6
User & Date: gerald 2012-11-05 14:07:36
Context
2012-11-06 08:19
Documented changes in respond. check-in: b0f33e9a8c user: oehhar tags: trunk
2012-11-05 14:07
Additional corrections to embedded code. check-in: 8ab30a71a3 user: gerald tags: trunk
2012-11-04 19:20
Move default content type to a configurable option. check-in: df85e4e49c user: gerald tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to Embedded.tcl.

42
43
44
45
46
47
48



49
50
51
52
53
54
55
...
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
...
311
312
313
314
315
316
317


318























































319
320
321
322
323
324
325
...
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
...
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
...
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
...
563
564
565
566
567
568
569
570
571

572
573
574
575
576
577
578
579
580
581
582
583
namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}



}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
#
# Description : Send response back to user.
#
# Arguments :
#       sock -- Socket to send reply on
#       code -- Code to send
#       body -- HTML body to send
#       head -- HTML header to send
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::respond {sock code body {head ""}} {


    puts -nonewline $sock "HTTP/1.0 $code ???\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]\n$head\n$body"























































}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
#
###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 Unauthorized "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::log warning "Unauthorized from $ip"
        return -code error
    }
}

 
###########################################################################
................................................................................
###########################################################################
proc ::WS::Embeded::handler {port sock ip reqstring auth} {
    variable portInfo
    upvar #0 ::WS::Embeded::Httpd$sock req

    if {[catch {checkauth $port $sock $ip $auth}]} {
        ::log::log warning {Auth Failed}
        return;
    }

    set ::errorInfo {}
    array set req $reqstring
    #foreach var {type data code} {
    #    dict set req(reply) $var [set $var]
    #}
    set path "/[string trim $req(path) /]"
    if {[dict exists $portInfo($port,handlers) $path]} {
        set cmd [dict get $portInfo($port,handlers) $path]
        lappend cmd $sock {}
        #puts "Calling {$cmd}"
        if {[catch {eval $cmd} msg]} {
            ::log::log error [list 404 b $msg]
            respond $sock 404 Error $msg
        } else {
            set type [dict get $req(reply) type]
            set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]]
            if {$encoding ni [encoding names]} {
                set encoding utf-8
                set type "[lindex [split $type ";"] 0]; charset=UTF-8"
            }
            set data [encoding convertto $encoding [dict get $req(reply) data]]
            set reply "HTTP/1.0 [dict get $req(reply) code] ???\n"
            append reply "Content-Type: $type\n"
            append reply "Connection: close\n"
            append reply "Content-length: [string length $data]\n"
            chan configure $sock -translation crlf
            puts $sock $reply
            chan configure $sock -translation binary
            puts -nonewline $sock $data
            ::log::log debug ok
        }
    } else {
        ::log::log warning {404 Error}
        respond $sock 404 Error "Error"
    }

    return;
}

 
###########################################################################
................................................................................
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::log info "Receviced request on $port for $ip:$clientport"

    array unset query reply
    chan configure $sock -translation crlf
    if {[catch {
        gets $sock line
        ::log::log debug "Request is: $line"
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::log warning  "Connection closed from $ip"
            catch {close $sock}
            return;
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {
            respond $sock 400 Error "Wrong request"
            ::log::log warning  "Wrong request: $line"
            catch {close $sock}
            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##
................................................................................
                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {
                respond $sock 501 Error "Method not implemented"
                ::log::log warning "Unsupported method '$method' from $ip"

            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 Error "Server error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}






>
>
>







 







|







 







>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|







 







|


<










|
|








|










|
|







 







|











<
|






<

<







 







<

>





|






42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
...
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
...
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
...
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
...
475
476
477
478
479
480
481
482
483
484

485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
...
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584

585
586
587
588
589
590
591

592

593
594
595
596
597
598
599
...
619
620
621
622
623
624
625

626
627
628
629
630
631
632
633
634
635
636
637
638
639
namespace eval ::WS::Embeded {

    array set portInfo {}

    set portList [list]
    set forever {}
    
    variable returnCodeText [dict create 200 OK 404 "Not Found"\
	    500 "Internal Server Error" 501 "Not Implemented"]
}

 
###########################################################################
#
# Public Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
#
# Description : Send response back to user.
#
# Arguments :
#       sock -- Socket to send reply on
#       code -- Code to send
#       body -- HTML body to send
#       head -- Additional HTML headers to send
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
................................................................................
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  03/28/2008  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::respond {sock code body {head ""}} {
    set body [encoding convertto iso8859-1 $body\r\n]
    chan configure $sock -translation crlf
    puts $sock "[httpreturncode $code]\nContent-Type: text/html; charset=ISO-8859-1\nConnection: close\nContent-length: [string length $body]"
    if {"" ne $head} {
	puts -nonewline $sock $head
    }
    # Separator head and body
    puts $sock ""
    chan configure $sock -translation binary
    puts -nonewline $sock $body
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
#
#>>BEGIN PRIVATE<<
#
# Procedure Name : ::WS::Embeded::httpreturncode
#
# Description : Format the first line of a http return including the status code
#
# Arguments :
#       code -- numerical http return code
#
# Returns :
#       Nothing
#
# Side-Effects : None
#
# Exception Conditions : None
#
# Pre-requisite Conditions : None
#
# Original Author : Gerald W. Lester
#
#>>END PRIVATE<<
#
# Maintenance History - as this file is modified, please be sure that you
#                       update this segment of the file header block by
#                       adding a complete entry at the bottom of the list.
#
# Version     Date     Programmer   Comments / Changes / Reasons
# -------  ----------  ----------   -------------------------------------------
#       1  10/05/2012  G.Lester     Initial version
#
#
###########################################################################
proc ::WS::Embeded::httpreturncode {code} {
    variable returnCodeText
    if {[dict exist $returnCodeText $code]} {
	set textCode [dict get $returnCodeText $code]
    } else {
	set textCode "???"
    }
    return "HTTP/1.0 $code $textCode"
}

 
###########################################################################
#
# Private Procedure Header - as this procedure is modified, please be sure
#                            that you update this header block. Thanks.
................................................................................
#
###########################################################################
proc ::WS::Embeded::checkauth {port sock ip auth} {
    variable portInfo

    if {[info exists portInfo($port,auths)] && [llength $portInfo($port,auths)] && [lsearch -exact $portInfo($port,auths) $auth]==-1} {
        set realm $portInfo($port,realm)
        respond $sock 401 "" "WWW-Authenticate: Basic realm=\"$realm\"\n"
        ::log::log warning "Unauthorized from $ip"
        return -code error
    }
}

 
###########################################################################
................................................................................
###########################################################################
proc ::WS::Embeded::handler {port sock ip reqstring auth} {
    variable portInfo
    upvar #0 ::WS::Embeded::Httpd$sock req

    if {[catch {checkauth $port $sock $ip $auth}]} {
        ::log::log warning {Auth Failed}
        return
    }


    array set req $reqstring
    #foreach var {type data code} {
    #    dict set req(reply) $var [set $var]
    #}
    set path "/[string trim $req(path) /]"
    if {[dict exists $portInfo($port,handlers) $path]} {
        set cmd [dict get $portInfo($port,handlers) $path]
        lappend cmd $sock {}
        #puts "Calling {$cmd}"
        if {[catch {eval $cmd} msg]} {
            ::log::log error "Return 404 due to eval error: $msg"
            respond $sock 404 "Error: $msg"
        } else {
            set type [dict get $req(reply) type]
            set encoding [string tolower [lindex [split [lindex [split $type {;}] 1] {=}] 1]]
            if {$encoding ni [encoding names]} {
                set encoding utf-8
                set type "[lindex [split $type ";"] 0]; charset=UTF-8"
            }
            set data [encoding convertto $encoding [dict get $req(reply) data]]
            set reply "[httpreturncode [dict get $req(reply) code]]\n"
            append reply "Content-Type: $type\n"
            append reply "Connection: close\n"
            append reply "Content-length: [string length $data]\n"
            chan configure $sock -translation crlf
            puts $sock $reply
            chan configure $sock -translation binary
            puts -nonewline $sock $data
            ::log::log debug ok
        }
    } else {
        ::log::log warning "404 Error: URL not found"
        respond $sock 404 "URL not found"
    }

    return;
}

 
###########################################################################
................................................................................
    variable portInfo

    upvar #0 ::WS::Embeded::Httpd$sock query
    ::log::log info "Receviced request on $port for $ip:$clientport"

    array unset query reply
    chan configure $sock -translation crlf
    if {1 == [catch {
        gets $sock line
        ::log::log debug "Request is: $line"
        set auth {}
        set request {}
        while {[gets $sock temp] > 0 && ![eof $sock]} {
            if {[regexp {^([^:]*):(.*)$} $temp -> key data]} {
                dict set request header [string tolower $key] [string trim $data]
            }
        }
        if {[eof $sock]} {
            ::log::log warning  "Connection closed from $ip"

            return
        }
        if {[dict exists $request header authorization]} {
            regexp -nocase {^basic +([^ ]+)$}\
                [dict get $request header authorization] -> auth
        }
        if {![regexp {^([^ ]+) +([^ ]+) ([^ ]+)$} $line -> method url version]} {

            ::log::log warning  "Wrong request: $line"

            return
        }
        switch -exact -- $method {
            POST {
                ##
                ## This is all broken and needs to be fixed
                ##
................................................................................
                #parray query
                handler $port $sock $ip [array get query] $auth
            }
            GET {
                handler $port $sock $ip [uri::split $url] $auth
            }
            default {

                ::log::log warning "Unsupported method '$method' from $ip"
                respond $sock 501 "Method not implemented"
            }
        }
    } msg]} {
        ::log::log error "Error: $msg"
        # catch this against an eventual closed socket
        catch {respond $sock 500 "Server Error"}
    }

    catch {flush $sock}
    catch {close $sock}
    return
}