Tcl Library Source Code

Check-in [4b3bc8df0b]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2018 Conference, Houston/TX, US, Oct 15-19
Send your abstracts to tclconference@googlegroups.com
or submit via the online form by Aug 20.

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

Overview
Comment:Httpd Module: Servers now pass control off to reply objects via a tailcall. Removed a puts statement in the example httpd app that was logging to stdout
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:4b3bc8df0b542a66b93925246fed32f7ea45437907d93928eed2be31e7fb93c7
User & Date: hypnotoad 2018-09-11 18:49:50
Context
2018-09-12
19:31
httpd module: Replaced naked calls to [chan copy] with a new co-subroutine ChanCopy which is part of the metaclass for the httpd module. Using ChanCopy means the coroutine can remain in control for the entire process of processing an http request. For large file transfers we were killing the coroutine and waking the object back up with a fileevent. Added a test for 404 Not Found errors check-in: bb27bb43b4 user: hypnotoad tags: hypnotoad
2018-09-11
18:49
Httpd Module: Servers now pass control off to reply objects via a tailcall. Removed a puts statement in the example httpd app that was logging to stdout check-in: 4b3bc8df0b user: hypnotoad tags: hypnotoad
18:19
Mime: Fixed a wrong version number on the package httpd: The example now uses the uri::direct method where appropriate. Fixed some typos and bugs in the uri::direct method. Fixed places in the code where error pages were asking for the html::header and html::footer methods. They haven't existed for a while. check-in: 05366363a0 user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to examples/httpd/httpd.tcl.

115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
  }
}

::clay::define ::docserver::server {
  superclass ::httpd::server

  method debug args {
    puts [list DEBUG {*}$args]
  }
  method log args {
    puts [list LOG {*}$args]
  }

}

set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {







|


|







115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
  }
}

::clay::define ::docserver::server {
  superclass ::httpd::server

  method debug args {
    #puts [list DEBUG {*}$args]
  }
  method log args {
    #puts [list LOG {*}$args]
  }

}

set serveropts [::httpd::server clay get server/]
foreach {f v}  [::clay::args_to_options {*}$::argv] {
  if {[dict exists $serveropts $f]} {

Changes to modules/httpd/build/server.tcl.

39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

  destructor {
    my stop
  }

  method connect {sock ip port} {
    ###
    # If an IP address is blocked
    # send a "go to hell" message
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
................................................................................
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      $pageobj dispatch $sock $reply
    } on error {err errdat} {
      my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {$pageobj destroy}
      catch {chan close $sock}
    }
  }







|
|







 







|







39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
...
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

  destructor {
    my stop
  }

  method connect {sock ip port} {
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
................................................................................
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      tailcall $pageobj dispatch $sock $reply
    } on error {err errdat} {
      my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {$pageobj destroy}
      catch {chan close $sock}
    }
  }

Changes to modules/httpd/httpd.tcl.

792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
...
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
...
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
....
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991

  destructor {
    my stop
  }

  method connect {sock ip port} {
    ###
    # If an IP address is blocked
    # send a "go to hell" message
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
................................................................................
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      my Headers_Process query
      set reply [my dispatch $query]
      puts [list REPLY $reply]
    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
................................................................................
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      $pageobj dispatch $sock $reply
    } on error {err errdat} {
      my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {$pageobj destroy}
      catch {chan close $sock}
    }
  }
................................................................................
  }

  method Dispatch_Dict {data} {
    my variable url_patterns
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host hostpat} $url_patterns {
      puts [list HOST $vhost | $host [string match $host $vhost]]
      if {![string match $host $vhost]} continue
      foreach {pattern info} $hostpat {
        puts [list URI $uri | $pattern [string match $pattern $uri]]
        if {![string match $pattern $uri]} continue
        set buffer $data
        foreach {f v} $info {
          dict set buffer $f $v
        }
        return $buffer
      }







|
|







 







<







 







|







 







<


<







792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
...
858
859
860
861
862
863
864

865
866
867
868
869
870
871
...
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
....
1973
1974
1975
1976
1977
1978
1979

1980
1981

1982
1983
1984
1985
1986
1987
1988

  destructor {
    my stop
  }

  method connect {sock ip port} {
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
      return
    }
    set uuid [my Uuid_Generate]
    set coro [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect $uuid $sock $ip]]]
................................................................................
      set mimetxt [my HttpHeaders $sock]
      dict set query UUID $uuid
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http [my ServerHeaders $ip $http_request $mimetxt]
      my Headers_Process query
      set reply [my dispatch $query]

    } on error {err errdat} {
      my debug [list uri: [dict getnull $query REQUEST_URI] ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {chan puts $sock "HTTP/1.0 400 Bad Request (The data is invalid)"}
      catch {chan close $sock}
      return
    }
................................................................................
      my log BadLocation $uuid $query
      dict set query http HTTP_STATUS 404
      dict set query template notfound
      dict set query mixin reply ::httpd::content.template
    }
    try {
      set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
      tailcall $pageobj dispatch $sock $reply
    } on error {err errdat} {
      my debug [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      my log BadRequest $uuid [list ip: $ip error: $err errorinfo: [dict get $errdat -errorinfo]]
      catch {$pageobj destroy}
      catch {chan close $sock}
    }
  }
................................................................................
  }

  method Dispatch_Dict {data} {
    my variable url_patterns
    set vhost [lindex [split [dict get $data http HTTP_HOST] :] 0]
    set uri   [dict get $data http REQUEST_PATH]
    foreach {host hostpat} $url_patterns {

      if {![string match $host $vhost]} continue
      foreach {pattern info} $hostpat {

        if {![string match $pattern $uri]} continue
        set buffer $data
        foreach {f v} $info {
          dict set buffer $f $v
        }
        return $buffer
      }