Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | Additional corrections to embedded code. |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | trunk |
Files: | files | file ages | folders |
SHA1: |
8ab30a71a35b36fb7644455c37a65ab2 |
User & Date: | gerald 2012-11-05 14:07:36.083 |
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 | 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. | > > > | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | 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. |
︙ | ︙ | |||
285 286 287 288 289 290 291 | # # Description : Send response back to user. # # Arguments : # sock -- Socket to send reply on # code -- Code to send # body -- HTML body to send | | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 | # # 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 |
︙ | ︙ | |||
311 312 313 314 315 316 317 | # Version Date Programmer Comments / Changes / Reasons # ------- ---------- ---------- ------------------------------------------- # 1 03/28/2008 G.Lester Initial version # # ########################################################################### proc ::WS::Embeded::respond {sock code body {head ""}} { | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # 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. |
︙ | ︙ | |||
360 361 362 363 364 365 366 | # ########################################################################### 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) | | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | # ########################################################################### 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 } } ########################################################################### |
︙ | ︙ | |||
415 416 417 418 419 420 421 | ########################################################################### 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} | | < | | | | | | 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 | ########################################################################### 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; } ########################################################################### |
︙ | ︙ | |||
507 508 509 510 511 512 513 | 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 | | < | < < | 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 | 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 ## |
︙ | ︙ | |||
563 564 565 566 567 568 569 | #parray query handler $port $sock $ip [array get query] $auth } GET { handler $port $sock $ip [uri::split $url] $auth } default { | < > | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | #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 } |