Tcl Library Source Code

Check-in [93b036eaeb]
Login

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

Overview
Comment:httpd module changes Added a server plugin which allows local process data to be sent via arguments and memchans instead of sockets. Updated tests to use the dict_dispatch plugin
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:93b036eaebd7f60ecd1b37a13c6308c40ae6381377de8d6fdaec0b35ff3b9e32
User & Date: hypnotoad 2018-06-05 21:50:47
Context
2018-06-14
21:11
Fixing an issue in httpd where mime headers to a closed channel were going into an overrun instead of simply terminating check-in: 120c9fa21e user: hypnotoad tags: hypnotoad
2018-06-05
21:50
httpd module changes Added a server plugin which allows local process data to be sent via arguments and memchans instead of sockets. Updated tests to use the dict_dispatch plugin check-in: 93b036eaeb user: hypnotoad tags: hypnotoad
18:04
Adding a sourcefile that was missing to implement plugins check-in: 313dd6aeac user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

17
18
19
20
21
22
23

24
25
26
27
28
29
30
package require tool
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

namespace eval httpd::content {}

namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}

tool::define ::httpd::mime {







>







17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
package require tool
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

namespace eval httpd::content {}

namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}

tool::define ::httpd::mime {

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

46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
..
98
99
100
101
102
103
104















































































































      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]

    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................
           dict set data prefix [my PrefixNormalize $pattern]
        }
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }
}






















































































































<







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
46
47
48
49
50
51
52

53
54
55
56
57
58
59
..
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]

    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................
           dict set data prefix [my PrefixNormalize $pattern]
        }
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }
}

tool::define ::httpd::reply.memchan {
  superclass ::httpd::reply

  method output {} {
    my variable reply_body
    return $reply_body
  }

  method DoOutput {} {}

  method close {} {
    # Neuter the channel closing mechanism we need the channel to stay alive
    # until the reader sucks out the info
  }
}


tool::define ::httpd::plugin.local_memchan {

  meta set plugin load: {
package require tcl::chan::events
package require tcl::chan::memchan
  }

  method local_memchan {command args} {
    my variable sock_to_coro
    switch $command {
      geturl {
        ###
        # Hook to allow a local process to ask for data without a socket
        ###
        set uuid [my Uuid_Generate]
        set ip 127.0.0.1
        set sock [::tcl::chan::memchan]
        set output [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect_Local $uuid $sock GET {*}$args]]]
        return $output
      }
      default {
        error "Valid: connect geturl"
      }
    }
  }

  ###
  # A modified connection method that passes simple GET request to an object
  # and pulls data directly from the reply_body data variable in the object
  #
  # Needed because memchan is bidirectional, and we can't seem to communicate that
  # the server is one side of the link and the reply is another
  ###
  method Connect_Local {uuid sock args} {
    chan event $sock readable {}

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid
    dict set query HTTP_HOST       localhost
    dict set query REMOTE_ADDR     127.0.0.1
    dict set query REMOTE_HOST     localhost
    dict set query LOCALHOST 1
    my counter url_hit

    dict set query REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query REQUEST_URI     [lindex $args 1]
    dict set query REQUEST_PATH    [dict get $uriinfo path]
    dict set query REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query DOCUMENT_ROOT   [my cget doc_root]
    dict set query QUERY_STRING    [dict get $uriinfo query]
    dict set query REQUEST_RAW     $args
    dict set query SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixinmap reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixinmap]} {
      set mixinmap [dict get $reply mixinmap]
    } else {
      set mixinmap {}
    }
    if {[dict exists $reply mixin]} {
      dict set mixinmap reply [dict get $reply mixin]
    }
    foreach item [dict keys $reply MIXIN_*] {
      set slot [string range $reply 6 end]
      dict set mixinmap [string tolower $slot] [dict get $reply $item]
    }
    $pageobj mixinmap {*}$mixinmap
    if {[dict exists $reply organ]} {
      $pageobj graft {*}[dict get $reply organ]
    }
    $pageobj dispatch $sock $reply
    set output [$pageobj output]
    catch {$pageobj destroy}
    return $output
  }
}

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

79
80
81
82
83
84
85

86

87
88
89
90
91
92
93
...
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query $qfld $v
        dict set query http $fld $v
      }

      dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]

      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}
................................................................................
      }
    }
    append body \n {  return [my Dispatch_Default $data]}
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method dispatch data $body

    ###
    # rebuild the Headers_Process method
    ###
    set body "\n try \{"
    append body \n "  upvar 1 \$varname query"
    foreach {slot class} $mixinmap {
      set script [$class meta getnull plugin headers:]







>
|
>







 







<







79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
...
228
229
230
231
232
233
234

235
236
237
238
239
240
241
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query $qfld $v
        dict set query http $fld $v
      }
      if {[string match 127.* $ip]} {
        dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      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}
................................................................................
      }
    }
    append body \n {  return [my Dispatch_Default $data]}
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method dispatch data $body

    ###
    # rebuild the Headers_Process method
    ###
    set body "\n try \{"
    append body \n "  upvar 1 \$varname query"
    foreach {slot class} $mixinmap {
      set script [$class meta getnull plugin headers:]

Changes to modules/httpd/httpd.tcl.

30
31
32
33
34
35
36

37
38
39
40
41
42
43
...
750
751
752
753
754
755
756

757

758
759
760
761

762
763
764
765
766
767
768
...
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
....
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
....
1981
1982
1983
1984
1985
1986
1987
1988




























1989



















































































1990
1991
1992
1993
1994
1995
1996
package require tool
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

namespace eval httpd::content {}

namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}

tool::define ::httpd::mime {
................................................................................
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query $qfld $v
        dict set query http $fld $v
      }

      dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]

      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
    }
    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
................................................................................
      }
    }
    append body \n {  return [my Dispatch_Default $data]}
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method dispatch data $body

    ###
    # rebuild the Headers_Process method
    ###
    set body "\n try \{"
    append body \n "  upvar 1 \$varname query"
    foreach {slot class} $mixinmap {
      set script [$class meta getnull plugin headers:]
................................................................................
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]

    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................
           dict set data prefix [my PrefixNormalize $pattern]
        }
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }
}





























###



















































































# END: plugin.tcl
###

namespace eval ::httpd {
    namespace export *
}








>







 







>
|
>




>







 







<







 







<







 








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







30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
...
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
...
901
902
903
904
905
906
907

908
909
910
911
912
913
914
....
1932
1933
1934
1935
1936
1937
1938

1939
1940
1941
1942
1943
1944
1945
....
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
package require tool
package require mime
package require fileutil
package require websocket
package require Markdown
package require uuid
package require fileutil::magic::filetype

namespace eval httpd::content {}

namespace eval ::url {}
namespace eval ::httpd {}
namespace eval ::scgi {}

tool::define ::httpd::mime {
................................................................................
          set qfld $fld
        } else {
          set qfld HTTP_$fld
        }
        dict set query $qfld $v
        dict set query http $fld $v
      }
      if {[string match 127.* $ip]} {
        dict set query LOCALHOST [expr {[lindex [split [dict getnull $query HTTP_HOST] :] 0] eq "localhost"}]
      }
      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]]
      puts [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
    }
    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
................................................................................
      }
    }
    append body \n {  return [my Dispatch_Default $data]}
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list DISPATCH ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method dispatch data $body

    ###
    # rebuild the Headers_Process method
    ###
    set body "\n try \{"
    append body \n "  upvar 1 \$varname query"
    foreach {slot class} $mixinmap {
      set script [$class meta getnull plugin headers:]
................................................................................
      return $reply
    }
  }

  method Dispatch_Dict {data} {
    set vhost [lindex [split [dict get $data HTTP_HOST] :] 0]
    set uri   [dict get $data REQUEST_PATH]

    foreach {host pattern info} [my uri patterns] {
      if {![string match $host $vhost]} continue
      if {![string match $pattern $uri]} continue
      set buffer $data
      foreach {f v} $info {
        dict set buffer $f $v
      }
................................................................................
           dict set data prefix [my PrefixNormalize $pattern]
        }
        dict set url_patterns $vhost [string trimleft $pattern /] $data
      }
    }
  }
}

tool::define ::httpd::reply.memchan {
  superclass ::httpd::reply

  method output {} {
    my variable reply_body
    return $reply_body
  }

  method DoOutput {} {}

  method close {} {
    # Neuter the channel closing mechanism we need the channel to stay alive
    # until the reader sucks out the info
  }
}


tool::define ::httpd::plugin.local_memchan {

  meta set plugin load: {
package require tcl::chan::events
package require tcl::chan::memchan
  }

  method local_memchan {command args} {
    my variable sock_to_coro
    switch $command {
      geturl {
        ###
        # Hook to allow a local process to ask for data without a socket
        ###
        set uuid [my Uuid_Generate]
        set ip 127.0.0.1
        set sock [::tcl::chan::memchan]
        set output [coroutine ::httpd::coro::$uuid {*}[namespace code [list my Connect_Local $uuid $sock GET {*}$args]]]
        return $output
      }
      default {
        error "Valid: connect geturl"
      }
    }
  }

  ###
  # A modified connection method that passes simple GET request to an object
  # and pulls data directly from the reply_body data variable in the object
  #
  # Needed because memchan is bidirectional, and we can't seem to communicate that
  # the server is one side of the link and the reply is another
  ###
  method Connect_Local {uuid sock args} {
    chan event $sock readable {}

    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
    set ip 127.0.0.1
    dict set query UUID $uuid
    dict set query HTTP_HOST       localhost
    dict set query REMOTE_ADDR     127.0.0.1
    dict set query REMOTE_HOST     localhost
    dict set query LOCALHOST 1
    my counter url_hit

    dict set query REQUEST_METHOD  [lindex $args 0]
    set uriinfo [::uri::split [lindex $args 1]]
    dict set query REQUEST_URI     [lindex $args 1]
    dict set query REQUEST_PATH    [dict get $uriinfo path]
    dict set query REQUEST_VERSION [lindex [split [lindex $args end] /] end]
    dict set query DOCUMENT_ROOT   [my cget doc_root]
    dict set query QUERY_STRING    [dict get $uriinfo query]
    dict set query REQUEST_RAW     $args
    dict set query SERVER_PORT     [my port_listening]
    my Headers_Process query
    set reply [my dispatch $query]

    if {[llength $reply]==0} {
      my log BadLocation $uuid $query
      my log BadLocation $uuid $query
      dict set query HTTP_STATUS 404
      dict set query template notfound
      dict set query mixinmap reply ::httpd::content.template
    }

    set class ::httpd::reply.memchan
    set pageobj [$class create ::httpd::object::$uuid [self]]
    if {[dict exists $reply mixinmap]} {
      set mixinmap [dict get $reply mixinmap]
    } else {
      set mixinmap {}
    }
    if {[dict exists $reply mixin]} {
      dict set mixinmap reply [dict get $reply mixin]
    }
    foreach item [dict keys $reply MIXIN_*] {
      set slot [string range $reply 6 end]
      dict set mixinmap [string tolower $slot] [dict get $reply $item]
    }
    $pageobj mixinmap {*}$mixinmap
    if {[dict exists $reply organ]} {
      $pageobj graft {*}[dict get $reply organ]
    }
    $pageobj dispatch $sock $reply
    set output [$pageobj output]
    catch {$pageobj destroy}
    return $output
  }
}


###
# END: plugin.tcl
###

namespace eval ::httpd {
    namespace export *
}

Changes to modules/httpd/httpd.test.

23
24
25
26
27
28
29



30
31
32
33
34
35
36
...
217
218
219
220
221
222
223

224
225
226
227
228
229
230
...
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
...
405
406
407
408
409
410
411

412
413
414
415
416
417
418
...
450
451
452
453
454
455
456








457
458
459
460
461
462
463
...
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
  use coroutine/coroutine.tcl coroutine

  use dicttool/dicttool.tcl dicttool
  use cron/cron.tcl cron
  use oodialect/oodialect.tcl oo::dialect
  use oometa/oometa.tcl oo::meta
  use tool/tool.tcl tool



}

testing {
  useLocal httpd.tcl httpd
}

# Set to true for debugging and traces
................................................................................
###
# Build the server
###
set DIR [file dirname [file normalize [info script]]]
set ::DEMOROOT $DIR

::httpd::server create TESTAPP port 10001

TESTAPP uri add /     [list mixin ::test::content.echo]
TESTAPP uri add /echo [list mixin ::test::content.echo]
TESTAPP uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTAPP uri add /time [list mixin ::test::content.time]
TESTAPP uri add /error [list mixin ::test::content.error]

# Catch all
................................................................................
    return [::socket localhost [my http_info get proxy_port]]
  }
}


::httpd::server create TESTPROXY port 10002
TESTAPP   uri add /proxy*     [list mixin ::test::content.proxy proxy_port [TESTPROXY port_listening]]

TESTPROXY uri add /     [list mixin ::test::content.echo]
TESTPROXY uri add /echo [list mixin ::test::content.echo]
TESTPROXY uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTPROXY uri add /time [list mixin ::test::content.time]
TESTPROXY uri add /error [list mixin ::test::content.error]

::DEBUG puts httpd-proxy-0001
................................................................................
::httpd::test::compare $reply $checkreply
} {}



# -------------------------------------------------------------------------
# cgi


TESTAPP uri add /cgi-bin* [list mixin ::test::content.cgi path $::DEMOROOT]

set fout [open [file join $DIR test.tcl] w]
puts $fout {#!/usr/bin/tclsh

puts stdout "Status: 200 OK"
................................................................................
Status: 200 OK
Content-Type: text/plain
Content-Length: *

Hi!}
} {}










# -------------------------------------------------------------------------
namespace eval ::scgi {}
namespace eval ::scgi::test {}

###
# Minimal test harness for the .tests
................................................................................
tool::class create scgi::test::app {
  superclass ::httpd::server.scgi

  property reply_class ::scgi::test::reply
}

scgi::test::app create TESTSCGI port 10003

TESTSCGI uri add /     [list mixin ::test::content.echo]
TESTSCGI uri add /echo [list mixin ::test::content.echo]
TESTSCGI uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTSCGI uri add /time [list mixin ::test::content.time]
TESTSCGI uri add /error [list mixin ::test::content.error]

::DEBUG puts scgi-client-0001







>
>
>







 







>







 







|







 







>







 







>
>
>
>
>
>
>
>







 







|







23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
...
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
...
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
...
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
...
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
...
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
  use coroutine/coroutine.tcl coroutine

  use dicttool/dicttool.tcl dicttool
  use cron/cron.tcl cron
  use oodialect/oodialect.tcl oo::dialect
  use oometa/oometa.tcl oo::meta
  use tool/tool.tcl tool
  use virtchannel_core/core.tcl tcl::chan::core
  use virtchannel_core/events.tcl tcl::chan::events
  use virtchannel_base/memchan.tcl tcl::chan::memchan
}

testing {
  useLocal httpd.tcl httpd
}

# Set to true for debugging and traces
................................................................................
###
# Build the server
###
set DIR [file dirname [file normalize [info script]]]
set ::DEMOROOT $DIR

::httpd::server create TESTAPP port 10001
TESTAPP plugin dict_dispatch
TESTAPP uri add /     [list mixin ::test::content.echo]
TESTAPP uri add /echo [list mixin ::test::content.echo]
TESTAPP uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTAPP uri add /time [list mixin ::test::content.time]
TESTAPP uri add /error [list mixin ::test::content.error]

# Catch all
................................................................................
    return [::socket localhost [my http_info get proxy_port]]
  }
}


::httpd::server create TESTPROXY port 10002
TESTAPP   uri add /proxy*     [list mixin ::test::content.proxy proxy_port [TESTPROXY port_listening]]
TESTPROXY plugin dict_dispatch
TESTPROXY uri add /     [list mixin ::test::content.echo]
TESTPROXY uri add /echo [list mixin ::test::content.echo]
TESTPROXY uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTPROXY uri add /time [list mixin ::test::content.time]
TESTPROXY uri add /error [list mixin ::test::content.error]

::DEBUG puts httpd-proxy-0001
................................................................................
::httpd::test::compare $reply $checkreply
} {}



# -------------------------------------------------------------------------
# cgi
TESTAPP plugin local_memchan

TESTAPP uri add /cgi-bin* [list mixin ::test::content.cgi path $::DEMOROOT]

set fout [open [file join $DIR test.tcl] w]
puts $fout {#!/usr/bin/tclsh

puts stdout "Status: 200 OK"
................................................................................
Status: 200 OK
Content-Type: text/plain
Content-Length: *

Hi!}
} {}

###
# Test the local geturl method
###
set now [clock seconds]
set dat [TESTAPP local_memchan geturl /time]
test httpd-memchan-0001 {Memchan GET} {
  TESTAPP local_memchan geturl /time
} $now

# -------------------------------------------------------------------------
namespace eval ::scgi {}
namespace eval ::scgi::test {}

###
# Minimal test harness for the .tests
................................................................................
tool::class create scgi::test::app {
  superclass ::httpd::server.scgi

  property reply_class ::scgi::test::reply
}

scgi::test::app create TESTSCGI port 10003
TESTSCGI plugin dict_dispatch
TESTSCGI uri add /     [list mixin ::test::content.echo]
TESTSCGI uri add /echo [list mixin ::test::content.echo]
TESTSCGI uri add /file [list mixin ::test::content.file doc_root $::DEMOROOT]
TESTSCGI uri add /time [list mixin ::test::content.time]
TESTSCGI uri add /error [list mixin ::test::content.error]

::DEBUG puts scgi-client-0001