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: |
8ab30a71a35b36fb7644455c37a65ab2 |
| 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
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
}
|