Tcl Library Source Code

Check-in [d20a51f758]
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: Fixed a goof in redirect handlers. Fixed which headers are accessed for logging. Added a shim for web servers to provide a standard style mixin. Added a shim for servers to participate with their own private methods prior and following mixin dispatch. Added a hook for server to provide a local method for Headers
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:d20a51f758a29f6491cd64145212623568f5d23e929590d43bbd3268f3c49f70
User & Date: hypnotoad 2018-09-08 18:56:14
Context
2018-09-08
18:56
Pulling changes from trunk check-in: 57af8b6c63 user: hypnotoad tags: hypnotoad
18:56
Httpd module: Fixed a goof in redirect handlers. Fixed which headers are accessed for logging. Added a shim for web servers to provide a standard style mixin. Added a shim for servers to participate with their own private methods prior and following mixin dispatch. Added a hook for server to provide a local method for Headers check-in: d20a51f758 user: hypnotoad tags: hypnotoad
2018-09-07
14:27
Shifting standard HTTP fields out of the root of clay, and into the http leaf. Redirecting API calls to not ask directly from clay what it expected as an HTTP header, and instead use the "request" method. Bumped versions of clay and httpd to denote they are fundimentally new versions. Changes to Clay: Changed the "Evolve" method in Clay to the "InitializePublic" to match Tool and what OOmeta expects. While clay itself doesn't utilize options, it's initializers are aware of how they will be annotated by future versions of tool/tao Moved variable, array, and dict annotations out of the public/ branch and into their own roots. Mixin is now a leaf in the clay tree. Added more tests to clay Changes to httpd: Replaced calls to http_info with naked calls to the clay data structure. Explicit requests for HTTP header info now directed at the request method. Request now stores headers with CGI/SCGI comadible names. Changes to practcl: Minor fixups from clay changes. check-in: ab481a1f5b user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my request get LOCATION]
    my reply set Location [my request get LOCATION]
    set code  [my request get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my request get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {








|
|
|








|







4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my clay get LOCATION]
    my reply set Location [my clay get LOCATION]
    set code  [my clay get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my clay get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

Changes to modules/httpd/build/reply.inc.

164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
clay::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
clay::define ::test::content.time {
  # return the current system time
	method content {} {







|







164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
clay::define ::test::content.file {
	superclass ::httpd::content.file
	# Return a file
	# Note: this is using the content.file mixin which looks for the reply_file variable
	# and will auto-compute the Content-Type
	method content {} {
	  my reset
    set doc_root [my request get DOCUMENT_ROOT]
    my variable reply_file
    set reply_file [file join $doc_root index.html]
	}
}
clay::define ::test::content.time {
  # return the current system time
	method content {} {

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

48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get COOKIE] \
     REFERER [my request get REFERER] \
     USER_AGENT [my request get USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {







|
|
|







48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get HTTP_COOKIE] \
     REFERER [my request get HTTP_REFERER] \
     USER_AGENT [my request get HTTP_USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {

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

66
67
68
69
70
71
72

73
74
75
76
77
78
79
...
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
...
235
236
237
238
239
240
241





242
243
244
245
246
247
248
...
252
253
254
255
256
257
258

259
260
261
262
263
264
265

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt

      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }





  method Headers_Process varname {}

  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
................................................................................
    set script [$class clay search plugin/ load]
    eval $script

    ###
    # rebuild the dispatch method
    ###
    set body "\n try \{"





    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ dispatch]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    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 clay search plugin/ headers]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }







>







 







|












>
>
>
>







 







>
>
>
>
>







 







>







66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
...
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
215
216
217
...
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
...
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict getnull $reply http DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }

  method Dispatch_Local data {}

  method Headers_Local {varname} {}

  method Headers_Process varname {}

  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
................................................................................
    set script [$class clay search plugin/ load]
    eval $script

    ###
    # rebuild the dispatch method
    ###
    set body "\n try \{"
    append body \n {
  set reply [my Dispatch_Local $data]
  if {[dict size $reply]} {return $reply}
}

    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ dispatch]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    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"
    append body \n {  my Headers_Local query}
    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ headers]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }

Changes to modules/httpd/httpd.tcl.

330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
...
805
806
807
808
809
810
811

812
813
814
815
816
817
818
...
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944




945
946
947
948
949
950
951
...
974
975
976
977
978
979
980





981
982
983
984
985
986
987
...
991
992
993
994
995
996
997

998
999
1000
1001
1002
1003
1004
....
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get COOKIE] \
     REFERER [my request get REFERER] \
     USER_AGENT [my request get USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {
................................................................................

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt

      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }





  method Headers_Process varname {}

  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
................................................................................
    set script [$class clay search plugin/ load]
    eval $script

    ###
    # rebuild the dispatch method
    ###
    set body "\n try \{"





    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ dispatch]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    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 clay search plugin/ headers]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my request get LOCATION]
    my reply set Location [my request get LOCATION]
    set code  [my request get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my request get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {








|
|
|







 







>







 







|












>
>
>
>







 







>
>
>
>
>







 







>







 







|
|
|








|







330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
...
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
...
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
...
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
....
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
....
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
    }
  }

  method Log_Dispatched {} {
    my log Dispatched [dict create \
     REMOTE_ADDR [my request get REMOTE_ADDR] \
     REMOTE_HOST [my request get REMOTE_HOST] \
     COOKIE [my request get HTTP_COOKIE] \
     REFERER [my request get HTTP_REFERER] \
     USER_AGENT [my request get HTTP_USER_AGENT] \
     REQUEST_URI [my request get REQUEST_URI] \
     HTTP_HOST [my request get HTTP_HOST] \
     SESSION [my request get SESSION] \
    ]
  }

  method dispatch {newsock datastate} {
................................................................................

    my counter url_hit
    set line {}
    try {
      set readCount [::coroutine::util::gets_safety $sock 4096 line]
      set mimetxt [my HttpHeaders $sock]
      dict set query mimetxt $mimetxt
      dict set query mixin style [my clay get server/ style]
      dict set query http HTTP_HOST {}
      dict set query http CONTENT_LENGTH 0
      foreach {f v} [my MimeParse $mimetxt] {
        set fld [string toupper [string map {- _} $f]]
        if {$fld in {CONTENT_LENGTH CONTENT_TYPE}} {
          set qfld $fld
        } else {
................................................................................
    return [my Dispatch_Default $data]
  }

  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict getnull $reply http DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
      # Fall back to doc_root handling
      ###
      dict set reply prefix {}
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }

  method Dispatch_Local data {}

  method Headers_Local {varname} {}

  method Headers_Process varname {}

  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
................................................................................
    set script [$class clay search plugin/ load]
    eval $script

    ###
    # rebuild the dispatch method
    ###
    set body "\n try \{"
    append body \n {
  set reply [my Dispatch_Local $data]
  if {[dict size $reply]} {return $reply}
}

    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ dispatch]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    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"
    append body \n {  my Headers_Local query}
    foreach {slot class} $mixinmap {
      set script [$class clay search plugin/ headers]
      if {[string length $script]} {
        append body \n "# SLOT $slot"
        append body \n $script
      }
    }
................................................................................
    ###
    # Inject the location into the HTTP headers
    ###
    my variable reply_body
    set reply_body {}
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    set msg [my clay get LOCATION]
    my reply set Location [my clay get LOCATION]
    set code  [my clay get REDIRECT_CODE]
    if {$code eq {}} {
      set code 301
    }
    my reply set Status [list $code [my http_code_string $code]]
  }

  method content {} {
    set template [my <server> template redirect]
    set msg [my clay get LOCATION]
    set HTTP_STATUS [my reply get Status]
    my puts [subst $msg]
  }
}

::clay::define ::httpd::content.cache {

Changes to modules/httpd/httpd.test.

188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		#puts [list REPLY BODY WAS $reply_body]
	}
}
clay::define ::test::content.file {
	superclass ::httpd::content.file
	method content {} {
	  my reset
    set doc_root [my clay get doc_root]
    my variable reply_file
    set reply_file [file join $doc_root pkgIndex.tcl]
	}
}
clay::define ::test::content.time {
	method content {} {
		my variable reply_body







|







188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
		#puts [list REPLY BODY WAS $reply_body]
	}
}
clay::define ::test::content.file {
	superclass ::httpd::content.file
	method content {} {
	  my reset
    set doc_root [my request get DOCUMENT_ROOT]
    my variable reply_file
    set reply_file [file join $doc_root pkgIndex.tcl]
	}
}
clay::define ::test::content.time {
	method content {} {
		my variable reply_body