Tcl Library Source Code

Check-in [ac0f7f67c2]
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 modifications: The manual file for httpd is now generated dynamically during the call to build/build.tcl and is developed by scanning the source files and scraping comments. The test.tcl file generated during httpd.test is now deleted prior to ending the test. Redistributed the hard coded documentation files as comments in front of the methods they describe to be assembled by the manual file generator.
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:ac0f7f67c2a655875b81dab3a17a62d40f05413f7499f0789bfd3366c481b6b2
User & Date: hypnotoad 2018-09-15 14:04:47
Context
2018-09-15
23:15
Added an auto-documenter to the doctools module for use in module that build amalgamations in the same style a practcl, clay, and httpd. Practcl and Httpd now generate their manual page in this new manner. The positive is that every proc, class, and method are now auto-documented with arguments, even if we don't have comments for them yet. check-in: e6100e18d0 user: hypnotoad tags: hypnotoad
14:04
httpd modifications: The manual file for httpd is now generated dynamically during the call to build/build.tcl and is developed by scanning the source files and scraping comments. The test.tcl file generated during httpd.test is now deleted prior to ending the test. Redistributed the hard coded documentation files as comments in front of the methods they describe to be assembled by the manual file generator. check-in: ac0f7f67c2 user: hypnotoad tags: hypnotoad
2018-09-13
15:31
httpd tweak: Proxy replies and file transfers now run in end-of-file mode instead of fixed file size. Keeps from having to read too much into the headers to handle either Content-Size or Chunked encoding replies check-in: 8a1de41126 user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

1
2
3
4
5
6

7
































































































































































8
9
10
11

12
13
14
15
16
17
18
..
37
38
39
40
41
42
43
44
45





46
47
48
49
50
51
52
53
54
55





56
57
58
59
60
61
62
..
69
70
71
72
73
74
75


































































set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 4.3
set tclversion 8.6
set module [file tail $moddir]


































































































































































set fout [open [file join $moddir ${module}.tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion

dict set map {    } {} ;# strip indentation
dict set map "\t" {    } ;# reduce indentation (see cleanup)

puts $fout [string map $map {###
    # Amalgamated package for %module%
    # Do not edit directly, tweak the source in src/ and rerun
    # build.tcl
................................................................................
  cgi.tcl
  scgi.tcl
  websocket.tcl
} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin





  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $srcdir *.tcl]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  puts $fout [read $fin]
  close $fin





  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
    namespace eval ::%module% {
	namespace export *
................................................................................
###
set fout [open [file join $moddir pkgIndex.tcl] w]
puts $fout [string map $map {
    if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
    package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout








































































>

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



>







 







|

>
>
>
>
>








|

>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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
...
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
...
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
set srcdir [file dirname [file normalize [file join [pwd] [info script]]]]
set moddir [file dirname $srcdir]

set version 4.3
set tclversion 8.6
set module [file tail $moddir]
set filename $module

proc autodoc.arglist {arglist} {
  set result [dict create]
  foreach arg $arglist {
    set name [lindex $arg 0]
    dict set result $name positional 1
    dict set result $name mandatory  1
    if {$name in {args dictargs}} {
      switch [llength $arg] {
        1 {
          dict set result $name mandatory 0
        }
        2 {
          dict for {optname optinfo} [lindex $arg 1] {
            set optname [string trim $optname -:]
            dict set result $optname {positional 1 mandatory 0}
            dict for {f v} $optinfo {
              dict set result $optname [string trim $f -:] $v
            }
          }
        }
        default {
          error "Bad argument"
        }
      }
    } else {
      switch [llength $arg] {
        1 {
          dict set result $name mandatory 1
        }
        2 {
          dict set result $name mandatory 0
          dict set result $name default   [lindex $arg 1]
        }
        default {
          error "Bad argument"
        }
      }
    }
  }
  return $result
}

proc autodoc.proc {resultvar commentblock name arglist body} {
  upvar 1 $resultvar result
  set info [autodoc.comment $commentblock]
  if {![dict exists $info arglist]} {
    dict set info arglist [autodoc.arglist $arglist]
  }
  dict set result proc [string trim $name :] $info
}

proc autodoc.method {resultvar commentblock name args} {
  upvar 1 $resultvar result
  set info [autodoc.comment $commentblock]
  switch [llength $args] {
    1 {
      set arglist [lindex $args 0]
    }
    0 {
      set arglist dictargs
      #set body [lindex $args 0]
    }
    default {error "could not interpret method $name {*}$args"}
  }
  if {![dict exists $info arglist]} {
    dict set info arglist [autodoc.arglist $arglist]
  }
  dict set result method [string trim $name :] $info
}

proc autodoc.class {resultvar commentblock name body} {
  upvar 1 $resultvar result
  set info [autodoc.comment $commentblock]
  set commentblock {}
  foreach line [split $body \n] {
    append thisline $line \n
    if {![info complete $thisline]} continue
    set thisline [string trim $thisline]
    if {[string index $thisline 0] eq "#"} {
      append commentblock [string trimleft $thisline #] \n
      set thisline {}
      continue
    }
    set cmd [string trim [lindex $thisline 0] ":"]
    switch $cmd {
      superclass {
        dict set info ancestors [lrange $thisline 1 end]
        set commentblock {}
      }
      destructor -
      constructor {
        autodoc.method info $commentblock {*}[lrange $thisline 0 end-1]
        set commentblock {}
      }
      method -
      Ensemble {
        autodoc.method info $commentblock  {*}[lrange $thisline 1 end-1]
        set commentblock {}
      }
    }
    set thisline {}
  }
  dict set result class $name $info
}


proc autodoc.comment block {
  return [dict create comment $block]
}

proc autodoc.root {resultvar} {
  upvar 1 $resultvar result
  yield [info coroutine]
  set thisline {}
  set commentblock {}
  set linec 0
  while 1 {
    set line [yield]
    append thisline $line \n
    if {![info complete $thisline]} continue
    set thisline [string trim $thisline]
    if {[string index $thisline 0] eq "#"} {
      append commentblock [string trimleft $thisline #] \n
      set thisline {}
      continue
    }
    set cmd [string trim [lindex $thisline 0] ":"]
    switch $cmd {
      proc {
        autodoc.proc result $commentblock {*}[lrange $thisline 1 end]
        set commentblock {}
      }
      oo::define {
        if {[llength $thisline]==3} {
          lassign $thisline tcmd name body
          autodoc.class $commentblock $name $body
        } else {
          puts "Warning: bare oo::define in library"
        }
      }
      clay::define -
      tool::define {
        lassign $thisline tcmd name body
        autodoc.class result $commentblock $name $body
        set commentblock {}
      }
      oo::class {
        lassign $thisline tcmd mthd name body
        autodoc.class result $commentblock $name $body
        set commentblock {}
      }
    }
    set thisline {}
  }
}

set AutoDocInfo [dict create]
coroutine AutoDoc autodoc.root AutoDocInfo


set fout [open [file join $moddir ${filename}.tcl] w]
dict set map %module% $module
dict set map %version% $version
dict set map %tclversion% $tclversion
dict set map %filename% $filename
dict set map {    } {} ;# strip indentation
dict set map "\t" {    } ;# reduce indentation (see cleanup)

puts $fout [string map $map {###
    # Amalgamated package for %module%
    # Do not edit directly, tweak the source in src/ and rerun
    # build.tcl
................................................................................
  cgi.tcl
  scgi.tcl
  websocket.tcl
} {
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  set content [read $fin]
  close $fin
  puts $file
  foreach line [split $content \n] {
    AutoDoc $line
  }
  puts $fout $content
  puts $fout "###\n# END: [file tail $file]\n###"
}
# These files can be loaded in any order
foreach file [glob [file join $srcdir *.tcl]] {
  if {[file tail $file] in $loaded} continue
  lappend loaded $file
  set fin [open [file join $srcdir $file] r]
  puts $fout "###\n# START: [file tail $file]\n###"
  set content [read $fin]
  close $fin
  puts $file
  foreach line [split $content \n] {
    AutoDoc $line
  }
  puts $fout $content
  puts $fout "###\n# END: [file tail $file]\n###"
}

# Provide some cleanup and our final package provide
puts $fout [string map $map {
    namespace eval ::%module% {
	namespace export *
................................................................................
###
set fout [open [file join $moddir pkgIndex.tcl] w]
puts $fout [string map $map {
    if {![package vsatisfies [package provide Tcl] %tclversion%]} {return}
    package ifneeded %module% %version% [list source [file join $dir %module%.tcl]]
}]
close $fout

###
# Build the help file
###
set manout [open [file join $moddir $filename.man] w]
set fin    [open [file join $srcdir manual.txt] r]
puts $manout [string map $map [read $fin]]
close $fin
foreach type [dict keys $AutoDocInfo] {
  dict for {name info} [dict get $AutoDocInfo $type] {
    if {$type eq "class"} {
      puts $manout "\[section \{Class  $name\}\]"
      if {[dict exists $info method]} {
        puts $manout {[list_begin definitions]}
        dict for {method minfo} [dict get $info method] {
          puts $manout {}
          set line "\[call method \[cmd $method\]"
          if {[dict exists $minfo arglist]} {
            dict for {argname arginfo} [dict get $minfo arglist] {
              set positional 1
              set mandatory  1
              dict with arginfo {}
              if {$mandatory==0} {
                append line " ?"
              } else {
                append line " "
              }
              if {$positional} {
                append line "\[arg $argname"
              } else {
                append line "\[opt $argname"
                if {[dict exists $arginfo type]} {
                  append line " \[cmd [dict get $arginfo type]\]"
                } else {
                  append line " \[cmd $argname\]"
                }
              }
              append line "\]"
              if {$mandatory==0} {
                if {[dict exists $arginfo default]} {
                  append line " \[emph \"[dict get $arginfo default]\"\]"
                }
                append line "?"
              }
            }
          }
          append line \]
          puts $manout $line
          if {[dict exists $minfo comment]} {
            puts $manout [dict get $minfo comment]
          }
        }
        puts $manout {[list_end]}
      }
    } else {
      puts $manout "\[section [list $type $name]\]"
    }
    if {[dict exists $info comment]} {
      puts $manout [dict get $info comment]
    }
  }
}
set fin    [open [file join $srcdir footer.txt] r]
puts $manout [string map $map [read $fin]]
close $fin
close $manout

Deleted modules/httpd/build/content.inc.

1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
[section {Class ::httpd::content}]

The httpd module includes several ready to use implementations of content mixins
for common use cases. Options are passed in to the [cmd add_uri] method of the server.

[section {Class ::httpd::content.cgi}]

An implementation to relay requests to process which will accept post data
streamed in vie stdin, and sent a reply streamed to stdout.

[list_begin definitions]
[call method cgi_info]

Mandatory method to be replaced by the end user. If needed, activates the
process to proxy, and then returns a list of three values:

[arg exec] - The arguments to send to exec to fire off the responding process, minus the stdin/stdout redirection.

[list_end]

[section {Class ::httpd::content.file}]

An implementation to deliver files from the local file system.

[list_begin definitions]

[call option [cmd path]]

The root directory on the local file system to be exposed via http.

[call option [cmd prefix]]

The prefix of the URI portion to ignore when calculating relative file paths.
[list_end]

[section {Class ::httpd::content.proxy}]

An implementation to relay requests to another HTTP server, and relay
the results back across the request channel.

[list_begin definitions]
[call method proxy_info]

Mandatory method to be replaced by the end user. If needed, activates the
process to proxy, and then returns a list of three values:

[arg proxyhost] - The hostname where the proxy is located

[arg proxyport] - The port to connect to

[arg proxyscript] - A pre-amble block of text to send prior to the mirrored request

[list_end]

[section {Class ::httpd::content.scgi}]

An implementation to relay requests to a server listening on a socket
expecting SCGI encoded requests, and relay
the results back across the request channel.

[list_begin definitions]
[call method scgi_info]

Mandatory method to be replaced by the end user. If needed, activates the
process to proxy, and then returns a list of three values:

[arg scgihost] - The hostname where the scgi listener is located

[arg scgiport] - The port to connect to

[arg scgiscript] - The contents of the [arg SCRIPT_NAME] header to be sent

[list_end]

[section {Class ::httpd::content.websocket}]

A placeholder for a future implementation to manage requests that can expect to be
promoted to a Websocket. Currently it is an empty class.

[section {SCGI Server Functions}]

The HTTP module also provides an SCGI server implementation, as well as an HTTP
implementation. To use the SCGI functions, create an object of the [cmd http::server.scgi]
class instead of the [cmd http::server] class.

[section {Class ::httpd::reply.scgi}]

An modified [cmd http::reply] implementation that understands how to deal with
netstring encoded headers.

[section {Class ::httpd::server.scgi}]

A modified [cmd http::server] which is tailored to replying to request according to
the SCGI standard instead of the HTTP standard.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































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

157
158
159
160
161
162
163
164


165
166
167
168
169
170
171
...
243
244
245
246
247
248
249

250
251
252
253
254
255
256
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Minimalist MIME Header Parser


  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
      # This regexp picks up
      # key: value
      # MIME headers.  MIME headers may be continue with a line
................................................................................
        }
      }
      dict set result $ckey $data(mime,$key)
    }
    return $result
  }


  method Url_Decode data {
    regsub -all {\+} $data " " data
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
    return [subst $data]
  }








|
>
>







 







>







157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
...
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Converts a block of mime encoded text to a key/value list. If an exception is encountered,
  # the method will generate its own call to the [cmd error] method, and immediately invoke
  # the [cmd output] method to produce an error code and close the connection.
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
      # This regexp picks up
      # key: value
      # MIME headers.  MIME headers may be continue with a line
................................................................................
        }
      }
      dict set result $ckey $data(mime,$key)
    }
    return $result
  }

  # De-httpizes a string.
  method Url_Decode data {
    regsub -all {\+} $data " " data
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
    return [subst $data]
  }

Added modules/httpd/build/footer.txt.













>
>
>
>
>
>
1
2
3
4
5
6
[section AUTHORS]
Sean Woods

[vset CATEGORY network]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Added modules/httpd/build/manual.txt.







































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
[vset VERSION %version%]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin %module% n [vset VERSION]]
[keywords WWW]
[copyright {2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Tcl Web Server}]
[titledesc {A TclOO and coroutine based web server}]
[category  Networking]
[keywords TclOO]
[keywords http]
[keywords httpd]
[keywords httpserver]
[keywords services]
[require Tcl 8.6]
[require httpd [opt [vset VERSION]]]
[require uuid]
[require clay]
[require coroutine]
[require fileutil]
[require fileutil::magic::filetype]
[require websocket]
[require mime]
[require cron]
[require uri]
[require Markdown]
[description]
[para]

This module implements a web server, suitable for embedding in an
application. The server is object oriented, and contains all of the
fundamentals needed for a full service website.

[para]

[section {Minimal Example}]

Starting a web service requires starting a class of type
[cmd httpd::server], and providing that server with one or more URIs
to service, and [cmd httpd::reply] derived classes to generate them.

[example {
tool::define ::reply.hello {
  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<h1>Hello World!</h1>"
    my puts </BODY></HTML>
  }
}
::docserver::server create HTTPD port 8015 myaddr 127.0.0.1
HTTPD add_uri /* [list mixin reply.hello]
}]

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

43
44
45
46
47
48
49



50
51
52
53
54
55
56
..
61
62
63
64
65
66
67


68
69
70
71
72
73
74
  clay set plugin/ dispatch {
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }




  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 {
................................................................................
        }
        return $buffer
      }
    }
    return {}
  }



  Ensemble uri::add {vhosts patterns info} {
    my variable url_patterns
    foreach vhost $vhosts {
      foreach pattern $patterns {
        set data $info
        if {![dict exists $data prefix]} {
           dict set data prefix [my PrefixNormalize $pattern]







>
>
>







 







>
>







43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
..
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
  clay set plugin/ dispatch {
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  ###
  # Implementation of the dispatcher
  ###
  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 {
................................................................................
        }
        return $buffer
      }
    }
    return {}
  }

  ###
  #
  Ensemble uri::add {vhosts patterns info} {
    my variable url_patterns
    foreach vhost $vhosts {
      foreach pattern $patterns {
        set data $info
        if {![dict exists $data prefix]} {
           dict set data prefix [my PrefixNormalize $pattern]

Deleted modules/httpd/build/reply.inc.

1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
[section {Class ::httpd::reply}]

A class which shephards a request through the process of generating a
reply.

The socket associated with the reply is available at all times as the [arg chan]
variable.

The process of generating a reply begins with an [cmd httpd::server] generating a
[cmd http::class] object, mixing in a set of behaviors and then invoking the reply
object's [cmd dispatch] method.

In normal operations the [cmd dispatch] method:

[list_begin enumerated]

[enum]
Invokes the [cmd reset] method for the object to populate default headers.

[enum]
Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket

[enum]
Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a
dict that can be read via the [cmd request] method.

[enum]
Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object.

[enum]
Invokes the [cmd content] method for the object, generating an call to the [cmd error]
method if an exception is raised.

[enum]
Invokes the [cmd output] method for the object
[list_end]

[para]

[section {Reply Method Ensembles}]

The [cmd http::reply] class and its derivatives maintain several variables as dictionaries
internally. Access to these dictionaries is managed through a dedicated ensemble. The
ensemble implements most of the same behaviors as the [cmd dict] command.

Each ensemble implements the following methods above, beyond, or modifying standard dicts:

[list_begin definitions]

[call method [cmd ENSEMBLE::add] [arg field] [arg element]]

Add [arg element] to a list stored in [arg field], but only if it is not already present om the list.

[call method [cmd ENSEMBLE::dump]]

Return the current contents of the data structure as a key/value list.

[call method [cmd ENSEMBLE::get] [arg field]]

Return the value of the field [arg field], or an empty string if it does not exist.

[call method [cmd ENSEMBLE::reset]]

Return a key/value list of the default contents for this data structure.

[call method [cmd ENSEMBLE::remove] [arg field] [arg element]]

Remove all instances of [arg element] from the list stored in [arg field].

[call method [cmd ENSEMBLE::replace] [arg keyvaluelist]]

Replace the internal dict with the contents of [arg keyvaluelist]

[call method [cmd ENSEMBLE::reset]]

Replace the internal dict with the default state.

[call method [cmd ENSEMBLE::set] [arg field] [arg value]]

Set the value of [arg field] to [arg value].

[list_end]

[section {Reply Method Ensemble: http_info}]

Manages HTTP headers passed in by the server.

Ensemble Methods:

[list_begin definitions]

[call method [cmd http_info::netstring]]

Return the contents of this data structure as a netstring encoded block.

[list_end]

[section {Reply Method Ensemble: request}]

Managed data from MIME headers of the request.

[list_begin definitions]

[call method  [cmd request::parse] [arg string]]

Replace the contents of the data structure with information encoded in a MIME
formatted block of text ([arg string]).

[list_end]

[section {Reply Method Ensemble: reply}]

Manage the headers sent in the reply.


[list_begin definitions]

[call method [cmd reply::output]]

Return the contents of this data structure as a MIME encoded block appropriate
for an HTTP response.

[list_end]

[section {Reply Methods}]

[list_begin definitions]
[call method [cmd close]]

Terminate the transaction, and close the socket.

[call method [cmd HttpHeaders] [arg sock] [arg ?debug?]]

Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns
the stream as a block of text.

[call method [cmd dispatch] [arg newsock] [arg datastate]]

Take over control of the socket [arg newsock], and store that as the [arg chan] variable
for the object. This method runs through all of the steps of reading HTTP headers, generating
content, and closing the connection. (See class writetup).

[call method [cmd error] [arg code] [arg ?message?] [arg ?errorInfo?]]

Generate an error message of the specified [arg code], and display the [arg message] as the
reason for the exception. [arg errorInfo] is passed in from calls, but how or if it should be
displayed is a prerogative of the developer.

[call method [cmd content]]

Generate the content for the reply. This method is intended to be replaced by the mixin.

Developers have the option of streaming output to a buffer via the [cmd puts] method of the
reply, or simply populating the [arg reply_body] variable of the object.
The information returned by the [cmd content] method is not interpreted in any way.

If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will
auto-generate a 500 {Internal Error} message.

A typical implementation of [cmd content] look like:

[example {

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 {} {
		my variable reply_body
    my reply set Content-Type text/plain
		set reply_body [clock seconds]
	}
}
clay::define ::test::content.echo {
	method content {} {
		my variable reply_body
    my reply set Content-Type [my request get CONTENT_TYPE]
		set reply_body [my PostData [my request get CONTENT_LENGTH]]
	}
}
clay::define ::test::content.form_handler {
	method content {} {
	  set form [my FormData]
	  my reply set Content-Type {text/html; charset=UTF-8}
    my puts [my html_header {My Dynamic Page}]
    my puts "<BODY>"
    my puts "You Sent<p>"
    my puts "<TABLE>"
    foreach {f v} $form {
      my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
    }
    my puts "</TABLE><p>"
    my puts "Send some info:<p>"
    my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
    my puts "<TABLE>"
    foreach field {name rank serial_number} {
      set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
      if {[dict exists $form $field]} {
        append line " value=\"[dict get $form $field]\"""
      }
      append line " /></TD></TR>"
      my puts $line
    }
    my puts "</TABLE>"
    my puts [my html footer]
	}
}

}]

[call method [cmd EncodeStatus] [arg status]]

Formulate a standard HTTP status header from he string provided.

[call method FormData]

For GET requests, converts the QUERY_DATA header into a key/value list.

For POST requests, reads the Post data and converts that information to
a key/value list for application/x-www-form-urlencoded posts. For multipart
posts, it composites all of the MIME headers of the post to a singular key/value
list, and provides MIME_* information as computed by the [cmd mime] package, including
the MIME_TOKEN, which can be fed back into the mime package to read out the contents.

[call method MimeParse [arg mimetext]]

Converts a block of mime encoded text to a key/value list. If an exception is encountered,
the method will generate its own call to the [cmd error] method, and immediately invoke
the [cmd output] method to produce an error code and close the connection.

[call method [cmd DoOutput]]

Generates the the HTTP reply, and streams that reply back across [arg chan].

[call method PostData [arg length]]

Stream [arg length] bytes from the [arg chan] socket, but only of the request is a
POST or PUSH. Returns an empty string otherwise.

[call method [cmd puts] [arg string]]

Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline
character.

[call method [cmd reset]]

Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply]
structure back to the defaults for this object.

[call method [cmd timeOutCheck]]

Called from the [cmd http::server] object which spawned this reply. Checks to see
if too much time has elapsed while waiting for data or generating a reply, and issues
a timeout error to the request if it has, as well as destroy the object and close the
[arg chan] socket.

[call method [cmd timestamp]]

Return the current system time in the format: [example {%a, %d %b %Y %T %Z}]

[call method [cmd TransferComplete] [arg args]]

Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel
fed to it on the command line, and then destroys the object.

[example {
    ###
    # Output the body
    ###
    chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
    if {$length} {
      ###
      # Send any POST/PUT/etc content
      ###
      chan copy $sock $chan -size $SIZE -command [info coroutine]
      yield
    }
    catch {close $sock}
    chan flush $chan
}]

[call method [cmd Url_Decode] [arg string]]

De-httpizes a string.

[list_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


















































































































































































































































































































































































































































































































































































































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

1

2
























































































































































































































3
4
5
6
7
8
9
..
33
34
35
36
37
38
39



40
41
42
43
44
45
46
47
48
49
50



51
52
53
54
55
56
57
58
59
60
61
62
63














64
65
66
67
68
69
70
...
181
182
183
184
185
186
187



188
189
190
191
192
193
194
...
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
...
224
225
226
227
228
229
230









231
232
233
234
235
236
237
...
277
278
279
280
281
282
283


284
285
286
287
288
289
290
...
295
296
297
298
299
300
301





















302
303
304
305
306
307
308
...
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
...
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
###

# Define the reply class
























































































































































































































###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}
................................................................................
  ###
  # clean up on exit
  ###
  destructor {
    my close
  }




  method close {} {
    my variable chan
    if {[info exists chan] && $chan ne {}} {
      catch {chan event $chan readable {}}
      catch {chan event $chan writable {}}
      catch {chan flush $chan}
      catch {chan close $chan}
      set chan {}
    }
  }




  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 variable chan request
    try {
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      if {[dict exists $datastate mixin]} {
................................................................................
  ###
  method content {} {
    my puts [my html_header {Hello World!}]
    my puts "<H1>HELLO WORLD!</H1>"
    my puts [my html_footer]
  }




  method EncodeStatus {status} {
    return "HTTP/1.0 $status"
  }

  method log {type {info {}}} {
    my variable dispatched_time uuid
    my <server> log $type $uuid $info
................................................................................
  method CoroName {} {
    if {[info coroutine] eq {}} {
      return ::httpd::object::[my clay get UUID]
    }
  }

  ###
  # Output the result or error to the channel
  # and destroy this object
  ###
  method DoOutput {} {
    my variable reply_body chan
    if {$chan eq {}} return
    catch {
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
................................................................................
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }
    my destroy
  }










  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    set length [my request get CONTENT_LENGTH]
................................................................................
          lappend formdata [my Url_Decode $name] [my Url_Decode $value]
        }
      }
    }
    return $formdata
  }



  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
................................................................................
    }
    return $postdata
  }

  # Manage session data
  method Session_Load {} {}






















  method TransferComplete args {
    my variable chan transfer_complete
    set transfer_complete 1
    my log TransferComplete
    set chan {}
    foreach c $args {
      catch {chan event $c readable {}}
................................................................................
      catch {chan event $c writable {}}
      catch {chan flush $c}
      catch {chan close $c}
    }
    my destroy
  }

  ###
  # Append to the result buffer
  ###
  method puts line {
    my variable reply_body
    append reply_body $line \n
  }

  method RequestFind {field} {
    my variable request
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set"
      }
    }
  }

  ###
  # Reset the result
  ###
  method reset {} {
    my variable reply_body
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    my reply set Date [my timestamp]
    set reply_body {}
  }

  ###
  # Return true of this class as waited too long to respond
  ###

  method timeOutCheck {} {
    my variable dispatched_time
    if {([clock seconds]-$dispatched_time)>120} {
      ###
      # Something has lasted over 2 minutes. Kill this
      ###
      catch {
................................................................................
        my error 408 {Request Timed out}
        my DoOutput
      }
    }
  }

  ###
  # Return a timestamp
  ###
  method timestamp {} {
    return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
  }
}

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







 







>
>
>











>
>
>













>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>







 







|
|







 







>
>
>
>
>
>
>
>
>







 







>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
<







 







|
|
<








|
|
|
>







 







|





1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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
215
216
217
218
219
220
221
222
223
224
225
226
...
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
...
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
...
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
...
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
...
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
...
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
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
...
696
697
698
699
700
701
702
703
704

705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
...
724
725
726
727
728
729
730
731
732
733
734
735
736
###
# A class which shephards a request through the process of generating a
# reply.
#
# The socket associated with the reply is available at all times as the [arg chan]
# variable.
#
# The process of generating a reply begins with an [cmd httpd::server] generating a
# [cmd http::class] object, mixing in a set of behaviors and then invoking the reply
# object's [cmd dispatch] method.
#
# In normal operations the [cmd dispatch] method:
#
# [list_begin enumerated]
#
# [enum]
# Invokes the [cmd reset] method for the object to populate default headers.
#
# [enum]
# Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket
#
# [enum]
# Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a
# dict that can be read via the [cmd request] method.
#
# [enum]
# Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object.
#
# [enum]
# Invokes the [cmd content] method for the object, generating an call to the [cmd error]
# method if an exception is raised.
#
# [enum]
# Invokes the [cmd output] method for the object
# [list_end]
#
# [para]
#
# [section {Reply Method Ensembles}]
#
# The [cmd http::reply] class and its derivatives maintain several variables as dictionaries
# internally. Access to these dictionaries is managed through a dedicated ensemble. The
# ensemble implements most of the same behaviors as the [cmd dict] command.
#
# Each ensemble implements the following methods above, beyond, or modifying standard dicts:
#
# [list_begin definitions]
#
# [call method [cmd ENSEMBLE::add] [arg field] [arg element]]
#
# Add [arg element] to a list stored in [arg field], but only if it is not already present om the list.
#
# [call method [cmd ENSEMBLE::dump]]
#
# Return the current contents of the data structure as a key/value list.
#
# [call method [cmd ENSEMBLE::get] [arg field]]
#
# Return the value of the field [arg field], or an empty string if it does not exist.
#
# [call method [cmd ENSEMBLE::reset]]
#
# Return a key/value list of the default contents for this data structure.
#
# [call method [cmd ENSEMBLE::remove] [arg field] [arg element]]
#
# Remove all instances of [arg element] from the list stored in [arg field].
#
# [call method [cmd ENSEMBLE::replace] [arg keyvaluelist]]
#
# Replace the internal dict with the contents of [arg keyvaluelist]
#
# [call method [cmd ENSEMBLE::reset]]
#
# Replace the internal dict with the default state.
#
# [call method [cmd ENSEMBLE::set] [arg field] [arg value]]
#
# Set the value of [arg field] to [arg value].
#
# [list_end]
#
# [section {Reply Method Ensemble: http_info}]
#
# Manages HTTP headers passed in by the server.
#
# Ensemble Methods:
#
# [list_begin definitions]
#
# [call method [cmd http_info::netstring]]
#
# Return the contents of this data structure as a netstring encoded block.
#
# [list_end]
#
# [section {Reply Method Ensemble: request}]
#
# Managed data from MIME headers of the request.
#
# [list_begin definitions]
#
# [call method  [cmd request::parse] [arg string]]
#
# Replace the contents of the data structure with information encoded in a MIME
# formatted block of text ([arg string]).
#
# [list_end]
#
# [section {Reply Method Ensemble: reply}]
#
# Manage the headers sent in the reply.
#
#
# [list_begin definitions]
#
# [call method [cmd reply::output]]
#
# Return the contents of this data structure as a MIME encoded block appropriate
# for an HTTP response.
#
# [list_end]
#
# [section {Reply Methods}]
#
# [list_begin definitions]
# [call method [cmd close]]
#
# Terminate the transaction, and close the socket.
#
# [call method [cmd HttpHeaders] [arg sock] [arg ?debug?]]
#
# Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns
# the stream as a block of text.
#
# [call method [cmd dispatch] [arg newsock] [arg datastate]]
#
# Take over control of the socket [arg newsock], and store that as the [arg chan] variable
# for the object. This method runs through all of the steps of reading HTTP headers, generating
# content, and closing the connection. (See class writetup).
#
# [call method [cmd error] [arg code] [arg ?message?] [arg ?errorInfo?]]
#
# Generate an error message of the specified [arg code], and display the [arg message] as the
# reason for the exception. [arg errorInfo] is passed in from calls, but how or if it should be
# displayed is a prerogative of the developer.
#
# [call method [cmd content]]
#
# Generate the content for the reply. This method is intended to be replaced by the mixin.
#
# Developers have the option of streaming output to a buffer via the [cmd puts] method of the
# reply, or simply populating the [arg reply_body] variable of the object.
# The information returned by the [cmd content] method is not interpreted in any way.
#
# If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will
# auto-generate a 500 {Internal Error} message.
#
# A typical implementation of [cmd content] look like:
#
# [example {
#
# 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 {} {
# 		my variable reply_body
#     my reply set Content-Type text/plain
# 		set reply_body [clock seconds]
# 	}
# }
# clay::define ::test::content.echo {
# 	method content {} {
# 		my variable reply_body
#     my reply set Content-Type [my request get CONTENT_TYPE]
# 		set reply_body [my PostData [my request get CONTENT_LENGTH]]
# 	}
# }
# clay::define ::test::content.form_handler {
# 	method content {} {
# 	  set form [my FormData]
# 	  my reply set Content-Type {text/html; charset=UTF-8}
#     my puts [my html_header {My Dynamic Page}]
#     my puts "<BODY>"
#     my puts "You Sent<p>"
#     my puts "<TABLE>"
#     foreach {f v} $form {
#       my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
#     }
#     my puts "</TABLE><p>"
#     my puts "Send some info:<p>"
#     my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
#     my puts "<TABLE>"
#     foreach field {name rank serial_number} {
#       set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
#       if {[dict exists $form $field]} {
#         append line " value=\"[dict get $form $field]\"""
#       }
#       append line " /></TD></TR>"
#       my puts $line
#     }
#     my puts "</TABLE>"
#     my puts [my html footer]
# 	}
# }
#
# }]
# [list_end]
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}
................................................................................
  ###
  # clean up on exit
  ###
  destructor {
    my close
  }

  ###
  # Close channels opened by this object
  ###
  method close {} {
    my variable chan
    if {[info exists chan] && $chan ne {}} {
      catch {chan event $chan readable {}}
      catch {chan event $chan writable {}}
      catch {chan flush $chan}
      catch {chan close $chan}
      set chan {}
    }
  }

  ###
  # Record a dispatch event
  ###
  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] \
    ]
  }

  ###
  # Accept the handoff from the server object of the socket
  # [enph newsock] and feed it the state [emph datastate]
  #
  # Fields the [emph datastate] are looking for in particular are:
  #
  # mixin: A key/value list of slots and classes to be mixed into the
  # object prior to invoking [cmd Dispatch].
  #
  # http: A key/value list of values to populate the object's [emph request]
  # ensemble
  #
  # All other fields are passed along to the [emph clay] structure of the object.
  ###
  method dispatch {newsock datastate} {
    my variable chan request
    try {
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      if {[dict exists $datastate mixin]} {
................................................................................
  ###
  method content {} {
    my puts [my html_header {Hello World!}]
    my puts "<H1>HELLO WORLD!</H1>"
    my puts [my html_footer]
  }

  ###
  # Formulate a standard HTTP status header from he string provided.
  ###
  method EncodeStatus {status} {
    return "HTTP/1.0 $status"
  }

  method log {type {info {}}} {
    my variable dispatched_time uuid
    my <server> log $type $uuid $info
................................................................................
  method CoroName {} {
    if {[info coroutine] eq {}} {
      return ::httpd::object::[my clay get UUID]
    }
  }

  ###
  # Generates the the HTTP reply, streams that reply back across [arg chan],
  # and destroys the object.
  ###
  method DoOutput {} {
    my variable reply_body chan
    if {$chan eq {}} return
    catch {
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
................................................................................
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }
    my destroy
  }

  ###
  # For GET requests, converts the QUERY_DATA header into a key/value list.
  #
  # For POST requests, reads the Post data and converts that information to
  # a key/value list for application/x-www-form-urlencoded posts. For multipart
  # posts, it composites all of the MIME headers of the post to a singular key/value
  # list, and provides MIME_* information as computed by the [cmd mime] package, including
  # the MIME_TOKEN, which can be fed back into the mime package to read out the contents.
  ###
  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    set length [my request get CONTENT_LENGTH]
................................................................................
          lappend formdata [my Url_Decode $name] [my Url_Decode $value]
        }
      }
    }
    return $formdata
  }

  # Stream [arg length] bytes from the [arg chan] socket, but only of the request is a
  # POST or PUSH. Returns an empty string otherwise.
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
................................................................................
    }
    return $postdata
  }

  # Manage session data
  method Session_Load {} {}



  # Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel
  # fed to it on the command line, and then destroys the object.
  #
  # [example {
  #     ###
  #     # Output the body
  #     ###
  #     chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
  #     chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
  #     if {$length} {
  #       ###
  #       # Send any POST/PUT/etc content
  #       ###
  #       chan copy $sock $chan -size $SIZE -command [info coroutine]
  #       yield
  #     }
  #     catch {close $sock}
  #     chan flush $chan
  # }]
  method TransferComplete args {
    my variable chan transfer_complete
    set transfer_complete 1
    my log TransferComplete
    set chan {}
    foreach c $args {
      catch {chan event $c readable {}}
................................................................................
      catch {chan event $c writable {}}
      catch {chan flush $c}
      catch {chan close $c}
    }
    my destroy
  }

  # Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline
  # character.

  method puts line {
    my variable reply_body
    append reply_body $line \n
  }

  method RequestFind {field} {
    my variable request
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set"
      }
    }
  }

  # Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply]
  # structure back to the defaults for this object.

  method reset {} {
    my variable reply_body
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    my reply set Date [my timestamp]
    set reply_body {}
  }

  # Called from the [cmd http::server] object which spawned this reply. Checks to see
  # if too much time has elapsed while waiting for data or generating a reply, and issues
  # a timeout error to the request if it has, as well as destroy the object and close the
  # [arg chan] socket.
  method timeOutCheck {} {
    my variable dispatched_time
    if {([clock seconds]-$dispatched_time)>120} {
      ###
      # Something has lasted over 2 minutes. Kill this
      ###
      catch {
................................................................................
        my error 408 {Request Timed out}
        my DoOutput
      }
    }
  }

  ###
  # Return the current system time in the format: [example {%a, %d %b %Y %T %Z}]
  ###
  method timestamp {} {
    return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
  }
}

Deleted modules/httpd/build/server.inc.

1
2
3
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
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
[section {Class ::httpd::server}]

This class is the root object of the webserver. It is responsible
for opening the socket and providing the initial connection negotiation.

[list_begin definitions]
[call constructor ?port [opt port]? ?myaddr [opt ipaddr]|all? ?server_string [opt string]? ?server_name [opt string]?]
Build a new server object. [opt port] is the port to listen on

[call method [cmd add_uri] [arg pattern] [arg dict]]
Set the hander for a URI pattern. Information given in the [arg dict] is stored
in the data structure the [cmd dispatch] method uses. If a field called
[arg mixin] is given, that class will be mixed into the reply object immediately
after construction.

[call method [cmd connect] [arg sock] [arg ip] [arg port]]

Reply to an open socket. This method builds a coroutine to manage the remainder
of the connection. The coroutine's operations are driven by the [cmd Connect] method.

[call method [cmd Connect] [arg uuid] [arg sock] [arg ip]]

This method reads HTTP headers, and then consults the [cmd dispatch] method to
determine if the request is valid, and/or what kind of reply to generate. Under
normal cases, an object of class [cmd ::http::reply] is created.

Fields the server are looking for in particular are:

class: A class to use instead of the server's own [arg reply_class]

mixin: A class to be mixed into the new object after construction.

All other fields are passed along to the [cmd clay] structure of the
reply object.

After the class is created and the mixin is mixed in, the server invokes the
reply objects [cmd dispatch] method. This action passes control of the socket to
the reply object. The reply object manages the rest of the transaction, including
closing the socket.

[call method [cmd counter] [arg which]]

Increment an internal counter.

[call method [cmd CheckTimeout]]

Check open connections for a time out event.

[call method [cmd dispatch] [arg header_dict]]

Given a key/value list of information, return a data structure describing how
the server should reply.

[call method [cmd log] [arg args]]

Log an event. The input for args is free form. This method is intended
to be replaced by the user, and is a noop for a stock http::server object.

[call method [cmd port_listening]]

Return the actual port that httpd is listening on.

[call method [cmd PrefixNormalize] [arg prefix]]

For the stock version, trim trailing /'s and *'s from a prefix. This
method can be replaced by the end user to perform any other transformations
needed for the application.

[call method [cmd start]]

Open the socket listener.

[call method [cmd stop]]

Shut off the socket listener, and destroy any pending replies.

[call method [cmd template] [arg page]]

Return a template for the string [arg page]

[call method [cmd TemplateSearch] [arg page]]

Perform a search for the template that best matches [arg page]. This
can include local file searches, in-memory structures, or even
database lookups. The stock implementation simply looks for files
with a .tml or .html extension in the [opt doc_root] directory.

[call method [cmd Validate_Connection] [arg sock] [arg ip]]


Given a socket and an ip address, return true if this connection should
be terminated, or false if it should be allowed to continue. The stock
implementation always returns 0. This is intended for applications to
be able to implement black lists and/or provide security based on IP
address.

[list_end]
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































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

1
2
3



4
5
6
7
8
9
10
..
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28










29
30
31
32
33
34
35
..
37
38
39
40
41
42
43




44
45
46
47
48
49
50
..
85
86
87
88
89
90
91









92
93
94
95
96
97
98
...
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
...
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
...
261
262
263
264
265
266
267

268
269
270
271
272



273
274
275
276
277
278
279
280
281
282
283

284
285
286
287
288
289
290
...
305
306
307
308
309
310
311

312
313
314
315
316
317
318
...
323
324
325
326
327
328
329

330
331
332
333
334
335
336
337
338




339
340
341
342
343
344
345
...
373
374
375
376
377
378
379




380
381







382
383
384
385
386
387
388
389


390
391
392
393
394
395
396
397
398
399
400
401
###
# An httpd server with a template engine
# and a shim to insert URL domains



###
namespace eval ::httpd::object {}
namespace eval ::httpd::coro {}

::clay::define ::httpd::server {
  superclass ::httpd::mime

................................................................................
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}
  clay set server/ name     {127.0.0.1}

  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}

  constructor {args} {










    if {[llength $args]==1} {
      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
................................................................................
    my start
  }

  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}
................................................................................
    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
    }
    return $result
  }










  method Connect {uuid sock ip} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
................................................................................
      dict set reply template notfound
      dict set reply mixin reply ::httpd::content.template
    }
    set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
    tailcall $pageobj dispatch $sock $reply
  }


  method counter which {
    my variable counters
    incr counters($which)
  }

  ###
  # Clean up any process that has gone out for lunch
  ###
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        catch {$obj destroy}
................................................................................
      }
    }
  }

  method debug args {}

  ###
  # Route a request to the appropriate handler

  ###
  method dispatch {data} {
    set reply [my Dispatch_Local $data]
    if {[dict size $reply]} {
      return $reply
    }
    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 {}} {
      ###
................................................................................
      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 result [::dns::name $t]
    ::dns::cleanup $t
    return $result
  }





  method log args {
    # Do nothing for now
  }















  method plugin {slot {class {}}} {
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
................................................................................
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method Thread_start {} $body
  }


  method port_listening {} {
    my variable port_listening
    return $port_listening
  }




  method PrefixNormalize prefix {
    set prefix [string trimright $prefix /]
    set prefix [string trimright $prefix *]
    set prefix [string trimright $prefix /]
    return $prefix
  }

  method source {filename} {
    source $filename
  }


  method start {} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
................................................................................
    } else {
      lappend socklist [socket -server [namespace code [list my connect]] $port]
    }
    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }


  method stop {} {
    my variable socklist
    if {[info exists socklist]} {
      foreach sock $socklist {
        catch {close $sock}
      }
    }
................................................................................
  Ensemble SubObject::db {} {
    return [namespace current]::Sqlite_db
  }
  Ensemble SubObject::default {} {
    return [namespace current]::$method
  }


  method template page {
    my variable template
    if {[info exists template($page)]} {
      return $template($page)
    }
    set template($page) [my TemplateSearch $page]
    return $template($page)
  }





  method TemplateSearch page {
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
      return [::fileutil::cat [file join $doc_root $page.tml]]
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
................................................................................
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }





  method Thread_start {} {}








  method Uuid_Generate {} {
    return [::uuid::uuid generate]
  }

  ###
  # Return true if this IP address is blocked
  # The socket will be closed immediately after returning
  # This handler is welcome to send a polite error message


  ###
  method Validate_Connection {sock ip} {
    return 0
  }
}

###
# Provide a backward compadible alias
###
::clay::define ::httpd::server::dispatch {
    superclass ::httpd::server
}

|
<
>
>
>







 







<








|
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>







 







>
>
>
>
>
>
>
>
>







 







>






|







 







|
>









>
>
>
>
>







 







>
>
>
>
>


>
>
>
>
>


>
>
>
>


>
>
>
>
>










>
>
>
>




>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>





>
>
>











>







 







>







 







>









>
>
>
>







 







>
>
>
>


>
>
>
>
>
>
>





|
|
|
>
>












1
2

3
4
5
6
7
8
9
10
11
12
..
14
15
16
17
18
19
20

21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
..
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
...
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
...
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
...
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
...
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
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
...
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
...
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
###
# An httpd server with a template engine and a shim to insert URL domains.

#
# This class is the root object of the webserver. It is responsible
# for opening the socket and providing the initial connection negotiation.
###
namespace eval ::httpd::object {}
namespace eval ::httpd::coro {}

::clay::define ::httpd::server {
  superclass ::httpd::mime

................................................................................
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}


  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}

  constructor {
  {args {
    port        {default auto      comment {Port to listen on}}
    myaddr      {default 127.0.0.1 comment {IP address to listen on. "all" means all}}
    string      {default auto      comment {Value for SERVER_SOFTWARE in HTTP headers}}
    name        {default auto      comment {Value for SERVER_NAME in HTTP headers. Defaults to [info hostname]}}
    doc_root    {default {}        comment {File path to serve.}}
    reverse_dns {default 0         comment {Perform reverse DNS to convert IPs into hostnames}}
    configuration_file {default {} comment {Configuration file to load into server namespace}}
    protocol    {default {HTTP/1.1} comment {Value for SERVER_PROTOCOL in HTTP headers}}
  }}} {
    if {[llength $args]==1} {
      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
................................................................................
    my start
  }

  destructor {
    my stop
  }

  ###
  # Reply to an open socket. This method builds a coroutine to manage the remainder
  # of the connection. The coroutine's operations are driven by the [cmd Connect] method.
  ###
  method connect {sock ip port} {
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
................................................................................
    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
    }
    return $result
  }

  ###
  # This method reads HTTP headers, and then consults the [cmd dispatch] method to
  # determine if the request is valid, and/or what kind of reply to generate. Under
  # normal cases, an object of class [cmd ::http::reply] is created, and that class's
  # [cmd dispatch] method.
  # This action passes control of the socket to
  # the reply object. The reply object manages the rest of the transaction, including
  # closing the socket.
  ###
  method Connect {uuid sock ip} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
................................................................................
      dict set reply template notfound
      dict set reply mixin reply ::httpd::content.template
    }
    set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
    tailcall $pageobj dispatch $sock $reply
  }

  # Increment an internal counter.
  method counter which {
    my variable counters
    incr counters($which)
  }

  ###
  # Check open connections for a time out event.
  ###
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        catch {$obj destroy}
................................................................................
      }
    }
  }

  method debug args {}

  ###
  # Given a key/value list of information, return a data structure describing how
  # the server should reply.
  ###
  method dispatch {data} {
    set reply [my Dispatch_Local $data]
    if {[dict size $reply]} {
      return $reply
    }
    return [my Dispatch_Default $data]
  }

  ###
  # Method dispatch method of last resort before returning a 404 NOT FOUND error.
  # The default behavior is to look for a file in [emph DOCUMENT_ROOT] which
  # matches the query.
  ###
  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict getnull $reply http DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
................................................................................
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }

  ###
  # Method dispatch method invoked prior to invoking methods implemented by plugins.
  # If this method returns a non-empty dictionary, that structure will be passed to
  # the reply. The default is an empty implementation.
  ###
  method Dispatch_Local data {}

  ###
  # Introspect and possibly modify a data structure destined for a reply. This
  # method is invoked before invoking Header methods implemented by plugins.
  # The default implementation is empty.
  ###
  method Headers_Local {varname} {}

  ###
  # Introspect and possibly modify a data structure destined for a reply. This
  # method is built dynamically by the [cmd plugin] method.
  ###
  method Headers_Process varname {}

  ###
  # Convert an ip address to a host name. If the server/ reverse_dns flag
  # is false, this method simply returns the IP address back.
  # Internally, this method uses the [emph dns] module from tcllib.
  ###
  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
    set result [::dns::name $t]
    ::dns::cleanup $t
    return $result
  }

  ###
  # Log an event. The input for args is free form. This method is intended
  # to be replaced by the user, and is a noop for a stock http::server object.
  ###
  method log args {
    # Do nothing for now
  }

  ###
  # Incorporate behaviors from a plugin.
  # This method dynamically rebuilds the [cmd Dispatch] and [cmd Headers]
  # method. For every plugin, the server looks for the following entries in
  # [emph "clay plugin/"]:
  # [para]
  # [emph load] - A script to invoke in the server's namespace during the [cmd plugin] method invokation.
  # [para]
  # [emph dispatch] - A script to stitch into the server's [cmd Dispatch] method.
  # [para]
  # [emph headers] - A script to stitch into the server's [cmd Headers] method.
  # [para]
  # [emph thread] - A script to stitch into the server's [cmd Thread_start] method.
  ###
  method plugin {slot {class {}}} {
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
................................................................................
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method Thread_start {} $body
  }

  # Return the actual port that httpd is listening on.
  method port_listening {} {
    my variable port_listening
    return $port_listening
  }

  # For the stock version, trim trailing /'s and *'s from a prefix. This
  # method can be replaced by the end user to perform any other transformations
  # needed for the application.
  method PrefixNormalize prefix {
    set prefix [string trimright $prefix /]
    set prefix [string trimright $prefix *]
    set prefix [string trimright $prefix /]
    return $prefix
  }

  method source {filename} {
    source $filename
  }

  # Open the socket listener.
  method start {} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
................................................................................
    } else {
      lappend socklist [socket -server [namespace code [list my connect]] $port]
    }
    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }

  # Shut off the socket listener, and destroy any pending replies.
  method stop {} {
    my variable socklist
    if {[info exists socklist]} {
      foreach sock $socklist {
        catch {close $sock}
      }
    }
................................................................................
  Ensemble SubObject::db {} {
    return [namespace current]::Sqlite_db
  }
  Ensemble SubObject::default {} {
    return [namespace current]::$method
  }

  # Return a template for the string [arg page]
  method template page {
    my variable template
    if {[info exists template($page)]} {
      return $template($page)
    }
    set template($page) [my TemplateSearch $page]
    return $template($page)
  }

  # Perform a search for the template that best matches [arg page]. This
  # can include local file searches, in-memory structures, or even
  # database lookups. The stock implementation simply looks for files
  # with a .tml or .html extension in the [opt doc_root] directory.
  method TemplateSearch page {
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
      return [::fileutil::cat [file join $doc_root $page.tml]]
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
................................................................................
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }

  ###
  # Built by the [cmd plugin] method. Called by the [cmd start] method. Intended
  # to allow plugins to spawn worker threads.
  ###
  method Thread_start {} {}

  ###
  # Generate a GUUID. Used to ensure every request has a unique ID.
  # The default implementation is:
  # [example {
  #   return [::uuid::uuid generate]
  # }]
  ###
  method Uuid_Generate {} {
    return [::uuid::uuid generate]
  }

  ###
  # Given a socket and an ip address, return true if this connection should
  # be terminated, or false if it should be allowed to continue. The stock
  # implementation always returns 0. This is intended for applications to
  # be able to implement black lists and/or provide security based on IP
  # address.
  ###
  method Validate_Connection {sock ip} {
    return 0
  }
}

###
# Provide a backward compadible alias
###
::clay::define ::httpd::server::dispatch {
    superclass ::httpd::server
}

Changes to modules/httpd/httpd.man.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
..
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56





















































































































































































































57
58
59
































































































































































































































































































































































































































































































































































































































60
61
62
63
64
65

[vset VERSION 4.1.1]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin tool n [vset VERSION]]
[keywords WWW]
[copyright {2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Tcl Web Server}]
[titledesc {A TclOO and coroutine based web server}]
[category  Networking]
[keywords TclOO]
[keywords http]
[keywords httpd]
[keywords httpserver]
[keywords services]
[require Tcl 8.6]
[require httpd [opt [vset VERSION]]]
[require sha1]
[require dicttool]
[require oo::meta]
[require oo::dialect]
[require tool]
[require coroutine]
[require fileutil]
[require fileutil::magic::filetype]
[require websocket]
[require mime]
[require cron]
[require uri]
................................................................................
Starting a web service requires starting a class of type
[cmd httpd::server], and providing that server with one or more URIs
to service, and [cmd httpd::reply] derived classes to generate them.

[example {
tool::define ::reply.hello {
  method content {} {
    my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
    my puts "<h1>Hello World!</h1>"
    my puts </BODY></HTML>
  }
}
::docserver::server create HTTPD port 8015 myaddr 127.0.0.1
HTTPD add_uri /* [list mixin reply.hello]
}]

[include build/server.inc]





















































































































































































































[include build/reply.inc]
[include build/content.inc]

































































































































































































































































































































































































































































































































































































































[section AUTHORS]
Sean Woods

[vset CATEGORY network]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

|

|












|
<
<
<
|







 







|
|
|






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
<

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>






>
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16



17
18
19
20
21
22
23
24
..
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
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
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
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
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
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
466
467
468
469
470
471
472
473
474
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
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
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
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
[vset VERSION 4.3]
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin httpd n [vset VERSION]]
[keywords WWW]
[copyright {2018 Sean Woods <yoda@etoyoc.com>}]
[moddesc   {Tcl Web Server}]
[titledesc {A TclOO and coroutine based web server}]
[category  Networking]
[keywords TclOO]
[keywords http]
[keywords httpd]
[keywords httpserver]
[keywords services]
[require Tcl 8.6]
[require httpd [opt [vset VERSION]]]
[require uuid]



[require clay]
[require coroutine]
[require fileutil]
[require fileutil::magic::filetype]
[require websocket]
[require mime]
[require cron]
[require uri]
................................................................................
Starting a web service requires starting a class of type
[cmd httpd::server], and providing that server with one or more URIs
to service, and [cmd httpd::reply] derived classes to generate them.

[example {
tool::define ::reply.hello {
  method content {} {
my puts "<HTML><HEAD><TITLE>IRM Dispatch Server</TITLE></HEAD><BODY>"
my puts "<h1>Hello World!</h1>"
my puts </BODY></HTML>
  }
}
::docserver::server create HTTPD port 8015 myaddr 127.0.0.1
HTTPD add_uri /* [list mixin reply.hello]
}]

[section {Class  ::httpd::mime}]
[list_begin definitions]

[call method [cmd ChannelCopy] [arg in] [arg out] ?[arg args]?]


[call method [cmd html_header] ?[arg title] [emph ""]? ?[arg args]?]


[call method [cmd html_footer] ?[arg args]?]


[call method [cmd http_code_string] [arg code]]


[call method [cmd HttpHeaders] [arg sock] ?[arg debug] [emph ""]?]


[call method [cmd HttpHeaders_Default]]


[call method [cmd HttpServerHeaders]]


[call method [cmd MimeParse] [arg mimetext]]

 Converts a block of mime encoded text to a key/value list. If an exception is encountered,
 the method will generate its own call to the [cmd error] method, and immediately invoke
 the [cmd output] method to produce an error code and close the connection.



[call method [cmd Url_Decode] [arg data]]
 De-httpizes a string.


[call method [cmd Url_PathCheck] [arg urlsuffix]]


[call method [cmd wait] [arg mode] [arg sock]]

[list_end]
 Author: Sean Woods, yoda@etoyoc.com

 Adapted from the "minihttpd.tcl" file distributed with Tclhttpd

 The working elements have been updated to operate as a TclOO object
 running with Tcl 8.6+. Global variables and hard coded tables are
 now resident with the object, allowing this server to be more easily
 embedded another program, as well as be adapted and extended to
 support the SCGI module


[section {Class  ::httpd::reply}]
[list_begin definitions]

[call method [cmd constructor] [arg ServerObj] ?[arg args]?]


[call method [cmd destructor] ?[arg dictargs]?]

 clean up on exit



[call method [cmd close]]

 Close channels opened by this object



[call method [cmd Log_Dispatched]]

 Record a dispatch event



[call method [cmd dispatch] [arg newsock] [arg datastate]]

 Accept the handoff from the server object of the socket
 [enph newsock] and feed it the state [emph datastate]

 Fields the [emph datastate] are looking for in particular are:

 mixin: A key/value list of slots and classes to be mixed into the
 object prior to invoking [cmd Dispatch].

 http: A key/value list of values to populate the object's [emph request]
 ensemble

 All other fields are passed along to the [emph clay] structure of the object.



[call method [cmd Dispatch]]


[call method [cmd html_css]]


[call method [cmd html_header] [arg title] ?[arg args]?]


[call method [cmd html_footer] ?[arg args]?]


[call method [cmd error] [arg code] ?[arg msg] [emph ""]? ?[arg errorInfo] [emph ""]?]


[call method [cmd content]]

 REPLACE ME:
 This method is the "meat" of your application.
 It writes to the result buffer via the "puts" method
 and can tweak the headers via "clay put header_reply"



[call method [cmd EncodeStatus] [arg status]]

 Formulate a standard HTTP status header from he string provided.



[call method [cmd log] [arg type] ?[arg info] [emph ""]?]


[call method [cmd CoroName]]


[call method [cmd DoOutput]]

 Generates the the HTTP reply, streams that reply back across [arg chan],
 and destroys the object.



[call method [cmd FormData]]

 For GET requests, converts the QUERY_DATA header into a key/value list.

 For POST requests, reads the Post data and converts that information to
 a key/value list for application/x-www-form-urlencoded posts. For multipart
 posts, it composites all of the MIME headers of the post to a singular key/value
 list, and provides MIME_* information as computed by the [cmd mime] package, including
 the MIME_TOKEN, which can be fed back into the mime package to read out the contents.



[call method [cmd PostData] [arg length]]
 Stream [arg length] bytes from the [arg chan] socket, but only of the request is a
 POST or PUSH. Returns an empty string otherwise.


[call method [cmd Session_Load]]
 Manage session data


[call method [cmd TransferComplete] ?[arg args]?]
 Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel
 fed to it on the command line, and then destroys the object.

 [example {
     ###
     # Output the body
     ###
     chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
     chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
     if {$length} {
       ###
       # Send any POST/PUT/etc content
       ###
       chan copy $sock $chan -size $SIZE -command [info coroutine]
       yield
     }
     catch {close $sock}
     chan flush $chan
 }]


[call method [cmd puts] [arg line]]
 Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline
 character.


[call method [cmd RequestFind] [arg field]]


[call method [cmd request] [arg subcommand] ?[arg args]?]


[call method [cmd reply] [arg subcommand] ?[arg args]?]


[call method [cmd reset]]
 Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply]
 structure back to the defaults for this object.


[call method [cmd timeOutCheck]]
 Called from the [cmd http::server] object which spawned this reply. Checks to see
 if too much time has elapsed while waiting for data or generating a reply, and issues
 a timeout error to the request if it has, as well as destroy the object and close the
 [arg chan] socket.


[call method [cmd timestamp]]

 Return the current system time in the format: [example {%a, %d %b %Y %T %Z}]


[list_end]

 A class which shephards a request through the process of generating a
 reply.


 The socket associated with the reply is available at all times as the [arg chan]
 variable.

 The process of generating a reply begins with an [cmd httpd::server] generating a
 [cmd http::class] object, mixing in a set of behaviors and then invoking the reply
 object's [cmd dispatch] method.

 In normal operations the [cmd dispatch] method:

 [list_begin enumerated]

 [enum]
 Invokes the [cmd reset] method for the object to populate default headers.

 [enum]
 Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket

 [enum]
 Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a
 dict that can be read via the [cmd request] method.

 [enum]
 Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object.

 [enum]
 Invokes the [cmd content] method for the object, generating an call to the [cmd error]
 method if an exception is raised.

 [enum]
 Invokes the [cmd output] method for the object
 [list_end]

 [para]

 [section {Reply Method Ensembles}]

 The [cmd http::reply] class and its derivatives maintain several variables as dictionaries
 internally. Access to these dictionaries is managed through a dedicated ensemble. The
 ensemble implements most of the same behaviors as the [cmd dict] command.

 Each ensemble implements the following methods above, beyond, or modifying standard dicts:

 [list_begin definitions]

 [call method [cmd ENSEMBLE::add] [arg field] [arg element]]

 Add [arg element] to a list stored in [arg field], but only if it is not already present om the list.

 [call method [cmd ENSEMBLE::dump]]

 Return the current contents of the data structure as a key/value list.

 [call method [cmd ENSEMBLE::get] [arg field]]

 Return the value of the field [arg field], or an empty string if it does not exist.

 [call method [cmd ENSEMBLE::reset]]

 Return a key/value list of the default contents for this data structure.

 [call method [cmd ENSEMBLE::remove] [arg field] [arg element]]

 Remove all instances of [arg element] from the list stored in [arg field].

 [call method [cmd ENSEMBLE::replace] [arg keyvaluelist]]

 Replace the internal dict with the contents of [arg keyvaluelist]

 [call method [cmd ENSEMBLE::reset]]

 Replace the internal dict with the default state.

 [call method [cmd ENSEMBLE::set] [arg field] [arg value]]

 Set the value of [arg field] to [arg value].

 [list_end]

 [section {Reply Method Ensemble: http_info}]

 Manages HTTP headers passed in by the server.

 Ensemble Methods:

 [list_begin definitions]

 [call method [cmd http_info::netstring]]

 Return the contents of this data structure as a netstring encoded block.

 [list_end]

 [section {Reply Method Ensemble: request}]

 Managed data from MIME headers of the request.

 [list_begin definitions]

 [call method  [cmd request::parse] [arg string]]

 Replace the contents of the data structure with information encoded in a MIME
 formatted block of text ([arg string]).

 [list_end]

 [section {Reply Method Ensemble: reply}]

 Manage the headers sent in the reply.


 [list_begin definitions]

 [call method [cmd reply::output]]

 Return the contents of this data structure as a MIME encoded block appropriate
 for an HTTP response.

 [list_end]

 [section {Reply Methods}]

 [list_begin definitions]
 [call method [cmd close]]

 Terminate the transaction, and close the socket.

 [call method [cmd HttpHeaders] [arg sock] [arg ?debug?]]

 Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns
 the stream as a block of text.

 [call method [cmd dispatch] [arg newsock] [arg datastate]]

 Take over control of the socket [arg newsock], and store that as the [arg chan] variable
 for the object. This method runs through all of the steps of reading HTTP headers, generating
 content, and closing the connection. (See class writetup).

 [call method [cmd error] [arg code] [arg ?message?] [arg ?errorInfo?]]

 Generate an error message of the specified [arg code], and display the [arg message] as the
 reason for the exception. [arg errorInfo] is passed in from calls, but how or if it should be
 displayed is a prerogative of the developer.

 [call method [cmd content]]

 Generate the content for the reply. This method is intended to be replaced by the mixin.

 Developers have the option of streaming output to a buffer via the [cmd puts] method of the
 reply, or simply populating the [arg reply_body] variable of the object.
 The information returned by the [cmd content] method is not interpreted in any way.

 If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will
 auto-generate a 500 {Internal Error} message.

 A typical implementation of [cmd content] look like:

 [example {

 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 {} {
 		my variable reply_body
     my reply set Content-Type text/plain
 		set reply_body [clock seconds]
 	}
 }
 clay::define ::test::content.echo {
 	method content {} {
 		my variable reply_body
     my reply set Content-Type [my request get CONTENT_TYPE]
 		set reply_body [my PostData [my request get CONTENT_LENGTH]]
 	}
 }
 clay::define ::test::content.form_handler {
 	method content {} {
 	  set form [my FormData]
 	  my reply set Content-Type {text/html; charset=UTF-8}
     my puts [my html_header {My Dynamic Page}]
     my puts "<BODY>"
     my puts "You Sent<p>"
     my puts "<TABLE>"
     foreach {f v} $form {
       my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
     }
     my puts "</TABLE><p>"
     my puts "Send some info:<p>"
     my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
     my puts "<TABLE>"
     foreach field {name rank serial_number} {
       set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
       if {[dict exists $form $field]} {
         append line " value=\"[dict get $form $field]\"""
       }
       append line " /></TD></TR>"
       my puts $line
     }
     my puts "</TABLE>"
     my puts [my html footer]
 	}
 }

 }]
 [list_end]


[section {Class  ::httpd::server}]
[list_begin definitions]

[call method [cmd constructor] [arg args] ?[arg port] [emph "auto"]? ?[arg myaddr] [emph "127.0.0.1"]? ?[arg string] [emph "auto"]? ?[arg name] [emph "auto"]? ?[arg doc_root] [emph ""]? ?[arg reverse_dns] [emph "0"]? ?[arg configuration_file] [emph ""]? ?[arg protocol] [emph "HTTP/1.1"]?]


[call method [cmd destructor] ?[arg dictargs]?]


[call method [cmd connect] [arg sock] [arg ip] [arg port]]

 Reply to an open socket. This method builds a coroutine to manage the remainder
 of the connection. The coroutine's operations are driven by the [cmd Connect] method.



[call method [cmd ServerHeaders] [arg ip] [arg http_request] [arg mimetxt]]


[call method [cmd Connect] [arg uuid] [arg sock] [arg ip]]

 This method reads HTTP headers, and then consults the [cmd dispatch] method to
 determine if the request is valid, and/or what kind of reply to generate. Under
 normal cases, an object of class [cmd ::http::reply] is created, and that class's
 [cmd dispatch] method.
 This action passes control of the socket to
 the reply object. The reply object manages the rest of the transaction, including
 closing the socket.



[call method [cmd counter] [arg which]]
 Increment an internal counter.


[call method [cmd CheckTimeout]]

 Check open connections for a time out event.



[call method [cmd debug] ?[arg args]?]


[call method [cmd dispatch] [arg data]]

 Given a key/value list of information, return a data structure describing how
 the server should reply.



[call method [cmd Dispatch_Default] [arg reply]]

 Method dispatch method of last resort before returning a 404 NOT FOUND error.
 The default behavior is to look for a file in [emph DOCUMENT_ROOT] which
 matches the query.



[call method [cmd Dispatch_Local] [arg data]]

 Method dispatch method invoked prior to invoking methods implemented by plugins.
 If this method returns a non-empty dictionary, that structure will be passed to
 the reply. The default is an empty implementation.



[call method [cmd Headers_Local] [arg varname]]

 Introspect and possibly modify a data structure destined for a reply. This
 method is invoked before invoking Header methods implemented by plugins.
 The default implementation is empty.



[call method [cmd Headers_Process] [arg varname]]

 Introspect and possibly modify a data structure destined for a reply. This
 method is built dynamically by the [cmd plugin] method.



[call method [cmd HostName] [arg ipaddr]]

 Convert an ip address to a host name. If the server/ reverse_dns flag
 is false, this method simply returns the IP address back.
 Internally, this method uses the [emph dns] module from tcllib.



[call method [cmd log] ?[arg args]?]

 Log an event. The input for args is free form. This method is intended
 to be replaced by the user, and is a noop for a stock http::server object.



[call method [cmd plugin] [arg slot] ?[arg class] [emph ""]?]

 Incorporate behaviors from a plugin.
 This method dynamically rebuilds the [cmd Dispatch] and [cmd Headers]
 method. For every plugin, the server looks for the following entries in
 [emph "clay plugin/"]:
 [para]
 [emph load] - A script to invoke in the server's namespace during the [cmd plugin] method invokation.
 [para]
 [emph dispatch] - A script to stitch into the server's [cmd Dispatch] method.
 [para]
 [emph headers] - A script to stitch into the server's [cmd Headers] method.
 [para]
 [emph thread] - A script to stitch into the server's [cmd Thread_start] method.



[call method [cmd port_listening]]
 Return the actual port that httpd is listening on.


[call method [cmd PrefixNormalize] [arg prefix]]
 For the stock version, trim trailing /'s and *'s from a prefix. This
 method can be replaced by the end user to perform any other transformations
 needed for the application.


[call method [cmd source] [arg filename]]


[call method [cmd start]]
 Open the socket listener.


[call method [cmd stop]]
 Shut off the socket listener, and destroy any pending replies.


[call method [cmd SubObject::db]]


[call method [cmd SubObject::default]]


[call method [cmd template] [arg page]]
 Return a template for the string [arg page]


[call method [cmd TemplateSearch] [arg page]]
 Perform a search for the template that best matches [arg page]. This
 can include local file searches, in-memory structures, or even
 database lookups. The stock implementation simply looks for files
 with a .tml or .html extension in the [opt doc_root] directory.


[call method [cmd Thread_start]]

 Built by the [cmd plugin] method. Called by the [cmd start] method. Intended
 to allow plugins to spawn worker threads.



[call method [cmd Uuid_Generate]]

 Generate a GUUID. Used to ensure every request has a unique ID.
 The default implementation is:
 [example {
   return [::uuid::uuid generate]
 }]



[call method [cmd Validate_Connection] [arg sock] [arg ip]]

 Given a socket and an ip address, return true if this connection should
 be terminated, or false if it should be allowed to continue. The stock
 implementation always returns 0. This is intended for applications to
 be able to implement black lists and/or provide security based on IP
 address.


[list_end]

 An httpd server with a template engine and a shim to insert URL domains.

 This class is the root object of the webserver. It is responsible
 for opening the socket and providing the initial connection negotiation.


[section {Class  ::httpd::server::dispatch}]

 Provide a backward compadible alias


[section {Class  ::httpd::content.redirect}]
[list_begin definitions]

[call method [cmd reset]]


[call method [cmd content]]

[list_end]

[section {Class  ::httpd::content.cache}]
[list_begin definitions]

[call method [cmd Dispatch]]

[list_end]

[section {Class  ::httpd::content.template}]
[list_begin definitions]

[call method [cmd content]]

[list_end]

[section {Class  ::httpd::content.file}]
[list_begin definitions]

[call method [cmd FileName]]


[call method [cmd DirectoryListing] [arg local_file]]


[call method [cmd content]]


[call method [cmd Dispatch]]

[list_end]

 Class to deliver Static content
 When utilized, this class is fed a local filename
 by the dispatcher


[section {Class  ::httpd::content.exec}]
[list_begin definitions]

[call method [cmd CgiExec] [arg execname] [arg script] [arg arglist]]


[call method [cmd Cgi_Executable] [arg script]]

[list_end]

[section {Class  ::httpd::content.proxy}]
[list_begin definitions]

[call method [cmd proxy_channel]]


[call method [cmd proxy_path]]


[call method [cmd ProxyRequest] [arg chana] [arg chanb]]


[call method [cmd ProxyReply] [arg chana] [arg chanb] ?[arg args]?]


[call method [cmd Dispatch]]

[list_end]

 Return data from an proxy process


[section {Class  ::httpd::content.cgi}]
[list_begin definitions]

[call method [cmd FileName]]


[call method [cmd proxy_channel]]


[call method [cmd ProxyRequest] [arg chana] [arg chanb]]


[call method [cmd ProxyReply] [arg chana] [arg chanb] ?[arg args]?]


[call method [cmd DirectoryListing] [arg local_file]]

 For most CGI applications a directory list is vorboten


[list_end]

[section {Class  ::httpd::protocol.scgi}]
[list_begin definitions]

[call method [cmd EncodeStatus] [arg status]]

[list_end]

 Return data from an SCGI process


[section {Class  ::httpd::content.scgi}]
[list_begin definitions]

[call method [cmd scgi_info]]


[call method [cmd proxy_channel]]


[call method [cmd ProxyRequest] [arg chana] [arg chanb]]


[call method [cmd ProxyReply] [arg chana] [arg chanb] ?[arg args]?]

[list_end]

[section {Class  ::httpd::server.scgi}]
[list_begin definitions]

[call method [cmd debug] ?[arg args]?]


[call method [cmd Connect] [arg uuid] [arg sock] [arg ip]]

[list_end]

 Act as an  SCGI Server


[section {Class  ::httpd::content.websocket}]

 Upgrade a connection to a websocket


[section {Class  ::httpd::plugin}]

 httpd plugin template


[section {Class  ::httpd::plugin.dict_dispatch}]
[list_begin definitions]

[call method [cmd Dispatch_Dict] [arg data]]

 Implementation of the dispatcher



[call method [cmd uri::add] [arg vhosts] [arg patterns] [arg info]]




[call method [cmd uri::direct] [arg vhosts] [arg patterns] [arg info] [arg body]]

[list_end]

 A rudimentary plugin that dispatches URLs from a dict
 data structure


[section {Class  ::httpd::reply.memchan}]
[list_begin definitions]

[call method [cmd output]]


[call method [cmd DoOutput]]


[call method [cmd close]]

[list_end]

[section {Class  ::httpd::plugin.local_memchan}]
[list_begin definitions]

[call method [cmd local_memchan] [arg command] ?[arg args]?]


[call method [cmd Connect_Local] [arg uuid] [arg sock] ?[arg args]?]

 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


[list_end]

[section AUTHORS]
Sean Woods

[vset CATEGORY network]
[include ../doctools2base/include/feedback.inc]
[manpage_end]

Changes to modules/httpd/httpd.tcl.

170
171
172
173
174
175
176
177


178
179
180
181
182
183
184
...
256
257
258
259
260
261
262

263
264
265
266
267
268
269
...
317
318
319
320
321
322
323

324
























































































































































































































325
326
327
328
329
330
331
...
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














386
387
388
389
390
391
392
...
503
504
505
506
507
508
509



510
511
512
513
514
515
516
...
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
...
546
547
548
549
550
551
552









553
554
555
556
557
558
559
...
599
600
601
602
603
604
605


606
607
608
609
610
611
612
...
617
618
619
620
621
622
623





















624
625
626
627
628
629
630
...
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
...
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767

768
769
770
771
772
773
774
...
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797



798
799
800
801
802
803
804
...
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822










823
824
825
826
827
828
829
...
831
832
833
834
835
836
837




838
839
840
841
842
843
844
...
879
880
881
882
883
884
885









886
887
888
889
890
891
892
...
914
915
916
917
918
919
920

921
922
923
924
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





952
953
954
955
956
957
958
...
962
963
964
965
966
967
968





969
970





971
972




973
974





975
976
977
978
979
980
981
982
983
984




985
986
987
988














989
990
991
992
993
994
995
....
1055
1056
1057
1058
1059
1060
1061

1062
1063
1064
1065
1066



1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077

1078
1079
1080
1081
1082
1083
1084
....
1099
1100
1101
1102
1103
1104
1105

1106
1107
1108
1109
1110
1111
1112
....
1117
1118
1119
1120
1121
1122
1123

1124
1125
1126
1127
1128
1129
1130
1131
1132




1133
1134
1135
1136
1137
1138
1139
....
1167
1168
1169
1170
1171
1172
1173




1174
1175







1176
1177
1178
1179
1180
1181
1182
1183


1184
1185
1186
1187
1188
1189
1190
....
1970
1971
1972
1973
1974
1975
1976



1977
1978
1979
1980
1981
1982
1983
....
1988
1989
1990
1991
1992
1993
1994


1995
1996
1997
1998
1999
2000
2001
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Minimalist MIME Header Parser


  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
      # This regexp picks up
      # key: value
      # MIME headers.  MIME headers may be continue with a line
................................................................................
        }
      }
      dict set result $ckey $data(mime,$key)
    }
    return $result
  }


  method Url_Decode data {
    regsub -all {\+} $data " " data
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
    return [subst $data]
  }

................................................................................
###
# END: core.tcl
###
###
# START: reply.tcl
###
###

# Define the reply class
























































































































































































































###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}
................................................................................
  ###
  # clean up on exit
  ###
  destructor {
    my close
  }




  method close {} {
    my variable chan
    if {[info exists chan] && $chan ne {}} {
      catch {chan event $chan readable {}}
      catch {chan event $chan writable {}}
      catch {chan flush $chan}
      catch {chan close $chan}
      set chan {}
    }
  }




  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 variable chan request
    try {
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      if {[dict exists $datastate mixin]} {
................................................................................
  ###
  method content {} {
    my puts [my html_header {Hello World!}]
    my puts "<H1>HELLO WORLD!</H1>"
    my puts [my html_footer]
  }




  method EncodeStatus {status} {
    return "HTTP/1.0 $status"
  }

  method log {type {info {}}} {
    my variable dispatched_time uuid
    my <server> log $type $uuid $info
................................................................................
  method CoroName {} {
    if {[info coroutine] eq {}} {
      return ::httpd::object::[my clay get UUID]
    }
  }

  ###
  # Output the result or error to the channel
  # and destroy this object
  ###
  method DoOutput {} {
    my variable reply_body chan
    if {$chan eq {}} return
    catch {
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
................................................................................
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }
    my destroy
  }










  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    set length [my request get CONTENT_LENGTH]
................................................................................
          lappend formdata [my Url_Decode $name] [my Url_Decode $value]
        }
      }
    }
    return $formdata
  }



  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
................................................................................
    }
    return $postdata
  }

  # Manage session data
  method Session_Load {} {}






















  method TransferComplete args {
    my variable chan transfer_complete
    set transfer_complete 1
    my log TransferComplete
    set chan {}
    foreach c $args {
      catch {chan event $c readable {}}
................................................................................
      catch {chan event $c writable {}}
      catch {chan flush $c}
      catch {chan close $c}
    }
    my destroy
  }

  ###
  # Append to the result buffer
  ###
  method puts line {
    my variable reply_body
    append reply_body $line \n
  }

  method RequestFind {field} {
    my variable request
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set"
      }
    }
  }

  ###
  # Reset the result
  ###
  method reset {} {
    my variable reply_body
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    my reply set Date [my timestamp]
    set reply_body {}
  }

  ###
  # Return true of this class as waited too long to respond
  ###

  method timeOutCheck {} {
    my variable dispatched_time
    if {([clock seconds]-$dispatched_time)>120} {
      ###
      # Something has lasted over 2 minutes. Kill this
      ###
      catch {
................................................................................
        my error 408 {Request Timed out}
        my DoOutput
      }
    }
  }

  ###
  # Return a timestamp
  ###
  method timestamp {} {
    return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
  }
}

###
# END: reply.tcl
###
###
# START: server.tcl
###
###
# An httpd server with a template engine
# and a shim to insert URL domains



###
namespace eval ::httpd::object {}
namespace eval ::httpd::coro {}

::clay::define ::httpd::server {
  superclass ::httpd::mime

................................................................................
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}
  clay set server/ name     {127.0.0.1}

  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}

  constructor {args} {










    if {[llength $args]==1} {
      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
................................................................................
    my start
  }

  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}
................................................................................
    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
    }
    return $result
  }










  method Connect {uuid sock ip} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
................................................................................
      dict set reply template notfound
      dict set reply mixin reply ::httpd::content.template
    }
    set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
    tailcall $pageobj dispatch $sock $reply
  }


  method counter which {
    my variable counters
    incr counters($which)
  }

  ###
  # Clean up any process that has gone out for lunch
  ###
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        catch {$obj destroy}
................................................................................
      }
    }
  }

  method debug args {}

  ###
  # Route a request to the appropriate handler

  ###
  method dispatch {data} {
    set reply [my Dispatch_Local $data]
    if {[dict size $reply]} {
      return $reply
    }
    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 {}} {
      ###
................................................................................
      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 result [::dns::name $t]
    ::dns::cleanup $t
    return $result
  }





  method log args {
    # Do nothing for now
  }















  method plugin {slot {class {}}} {
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
................................................................................
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method Thread_start {} $body
  }


  method port_listening {} {
    my variable port_listening
    return $port_listening
  }




  method PrefixNormalize prefix {
    set prefix [string trimright $prefix /]
    set prefix [string trimright $prefix *]
    set prefix [string trimright $prefix /]
    return $prefix
  }

  method source {filename} {
    source $filename
  }


  method start {} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
................................................................................
    } else {
      lappend socklist [socket -server [namespace code [list my connect]] $port]
    }
    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }


  method stop {} {
    my variable socklist
    if {[info exists socklist]} {
      foreach sock $socklist {
        catch {close $sock}
      }
    }
................................................................................
  Ensemble SubObject::db {} {
    return [namespace current]::Sqlite_db
  }
  Ensemble SubObject::default {} {
    return [namespace current]::$method
  }


  method template page {
    my variable template
    if {[info exists template($page)]} {
      return $template($page)
    }
    set template($page) [my TemplateSearch $page]
    return $template($page)
  }





  method TemplateSearch page {
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
      return [::fileutil::cat [file join $doc_root $page.tml]]
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
................................................................................
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }





  method Thread_start {} {}








  method Uuid_Generate {} {
    return [::uuid::uuid generate]
  }

  ###
  # Return true if this IP address is blocked
  # The socket will be closed immediately after returning
  # This handler is welcome to send a polite error message


  ###
  method Validate_Connection {sock ip} {
    return 0
  }
}

###
................................................................................
  clay set plugin/ dispatch {
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }




  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 {
................................................................................
        }
        return $buffer
      }
    }
    return {}
  }



  Ensemble uri::add {vhosts patterns info} {
    my variable url_patterns
    foreach vhost $vhosts {
      foreach pattern $patterns {
        set data $info
        if {![dict exists $data prefix]} {
           dict set data prefix [my PrefixNormalize $pattern]







|
>
>







 







>







 







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







 







>
>
>











>
>
>













>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>







 







|
|







 







>
>
>
>
>
>
>
>
>







 







>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







|
|
<







 







|
|
<








|
|
|
>







 







|













|
<
>
>
>







 







<








|
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>







 







>
>
>
>
>
>
>
>
>







 







>






|







 







|
>









>
>
>
>
>







 







>
>
>
>
>


>
>
>
>
>


>
>
>
>


>
>
>
>
>










>
>
>
>




>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>





>
>
>











>







 







>







 







>









>
>
>
>







 







>
>
>
>


>
>
>
>
>
>
>





|
|
|
>
>







 







>
>
>







 







>
>







170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
...
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
...
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
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
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
466
467
468
469
470
471
472
473
474
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
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
...
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
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
...
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
...
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
...
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
...
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
...
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
...
906
907
908
909
910
911
912
913
914

915
916
917
918
919
920
921
....
1021
1022
1023
1024
1025
1026
1027
1028
1029

1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
....
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070

1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
....
1082
1083
1084
1085
1086
1087
1088

1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
....
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
....
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
....
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
....
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
....
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
....
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
....
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
....
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
....
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
....
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
....
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
      REQUEST_VERSION  DOCUMENT_ROOT QUERY_STRING REQUEST_RAW
      GATEWAY_INTERFACE SERVER_PORT SERVER_HTTPS_PORT
      SERVER_NAME  SERVER_SOFTWARE SERVER_PROTOCOL
    }
  }

  ###
  # Converts a block of mime encoded text to a key/value list. If an exception is encountered,
  # the method will generate its own call to the [cmd error] method, and immediately invoke
  # the [cmd output] method to produce an error code and close the connection.
  ###
  method MimeParse mimetext {
    set data(mimeorder) {}
    foreach line [split $mimetext \n] {
      # This regexp picks up
      # key: value
      # MIME headers.  MIME headers may be continue with a line
................................................................................
        }
      }
      dict set result $ckey $data(mime,$key)
    }
    return $result
  }

  # De-httpizes a string.
  method Url_Decode data {
    regsub -all {\+} $data " " data
    regsub -all {([][$\\])} $data {\\\1} data
    regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data  {[format %c 0x\1]} data
    return [subst $data]
  }

................................................................................
###
# END: core.tcl
###
###
# START: reply.tcl
###
###
# A class which shephards a request through the process of generating a
# reply.
#
# The socket associated with the reply is available at all times as the [arg chan]
# variable.
#
# The process of generating a reply begins with an [cmd httpd::server] generating a
# [cmd http::class] object, mixing in a set of behaviors and then invoking the reply
# object's [cmd dispatch] method.
#
# In normal operations the [cmd dispatch] method:
#
# [list_begin enumerated]
#
# [enum]
# Invokes the [cmd reset] method for the object to populate default headers.
#
# [enum]
# Invokes the [cmd HttpHeaders] method to stream the MIME headers out of the socket
#
# [enum]
# Invokes the [cmd {request parse}] method to convert the stream of MIME headers into a
# dict that can be read via the [cmd request] method.
#
# [enum]
# Stores the raw stream of MIME headers in the [arg rawrequest] variable of the object.
#
# [enum]
# Invokes the [cmd content] method for the object, generating an call to the [cmd error]
# method if an exception is raised.
#
# [enum]
# Invokes the [cmd output] method for the object
# [list_end]
#
# [para]
#
# [section {Reply Method Ensembles}]
#
# The [cmd http::reply] class and its derivatives maintain several variables as dictionaries
# internally. Access to these dictionaries is managed through a dedicated ensemble. The
# ensemble implements most of the same behaviors as the [cmd dict] command.
#
# Each ensemble implements the following methods above, beyond, or modifying standard dicts:
#
# [list_begin definitions]
#
# [call method [cmd ENSEMBLE::add] [arg field] [arg element]]
#
# Add [arg element] to a list stored in [arg field], but only if it is not already present om the list.
#
# [call method [cmd ENSEMBLE::dump]]
#
# Return the current contents of the data structure as a key/value list.
#
# [call method [cmd ENSEMBLE::get] [arg field]]
#
# Return the value of the field [arg field], or an empty string if it does not exist.
#
# [call method [cmd ENSEMBLE::reset]]
#
# Return a key/value list of the default contents for this data structure.
#
# [call method [cmd ENSEMBLE::remove] [arg field] [arg element]]
#
# Remove all instances of [arg element] from the list stored in [arg field].
#
# [call method [cmd ENSEMBLE::replace] [arg keyvaluelist]]
#
# Replace the internal dict with the contents of [arg keyvaluelist]
#
# [call method [cmd ENSEMBLE::reset]]
#
# Replace the internal dict with the default state.
#
# [call method [cmd ENSEMBLE::set] [arg field] [arg value]]
#
# Set the value of [arg field] to [arg value].
#
# [list_end]
#
# [section {Reply Method Ensemble: http_info}]
#
# Manages HTTP headers passed in by the server.
#
# Ensemble Methods:
#
# [list_begin definitions]
#
# [call method [cmd http_info::netstring]]
#
# Return the contents of this data structure as a netstring encoded block.
#
# [list_end]
#
# [section {Reply Method Ensemble: request}]
#
# Managed data from MIME headers of the request.
#
# [list_begin definitions]
#
# [call method  [cmd request::parse] [arg string]]
#
# Replace the contents of the data structure with information encoded in a MIME
# formatted block of text ([arg string]).
#
# [list_end]
#
# [section {Reply Method Ensemble: reply}]
#
# Manage the headers sent in the reply.
#
#
# [list_begin definitions]
#
# [call method [cmd reply::output]]
#
# Return the contents of this data structure as a MIME encoded block appropriate
# for an HTTP response.
#
# [list_end]
#
# [section {Reply Methods}]
#
# [list_begin definitions]
# [call method [cmd close]]
#
# Terminate the transaction, and close the socket.
#
# [call method [cmd HttpHeaders] [arg sock] [arg ?debug?]]
#
# Stream MIME headers from the socket [arg sock], stopping at an empty line. Returns
# the stream as a block of text.
#
# [call method [cmd dispatch] [arg newsock] [arg datastate]]
#
# Take over control of the socket [arg newsock], and store that as the [arg chan] variable
# for the object. This method runs through all of the steps of reading HTTP headers, generating
# content, and closing the connection. (See class writetup).
#
# [call method [cmd error] [arg code] [arg ?message?] [arg ?errorInfo?]]
#
# Generate an error message of the specified [arg code], and display the [arg message] as the
# reason for the exception. [arg errorInfo] is passed in from calls, but how or if it should be
# displayed is a prerogative of the developer.
#
# [call method [cmd content]]
#
# Generate the content for the reply. This method is intended to be replaced by the mixin.
#
# Developers have the option of streaming output to a buffer via the [cmd puts] method of the
# reply, or simply populating the [arg reply_body] variable of the object.
# The information returned by the [cmd content] method is not interpreted in any way.
#
# If an exception is thrown (via the [cmd error] command in Tcl, for example) the caller will
# auto-generate a 500 {Internal Error} message.
#
# A typical implementation of [cmd content] look like:
#
# [example {
#
# 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 {} {
# 		my variable reply_body
#     my reply set Content-Type text/plain
# 		set reply_body [clock seconds]
# 	}
# }
# clay::define ::test::content.echo {
# 	method content {} {
# 		my variable reply_body
#     my reply set Content-Type [my request get CONTENT_TYPE]
# 		set reply_body [my PostData [my request get CONTENT_LENGTH]]
# 	}
# }
# clay::define ::test::content.form_handler {
# 	method content {} {
# 	  set form [my FormData]
# 	  my reply set Content-Type {text/html; charset=UTF-8}
#     my puts [my html_header {My Dynamic Page}]
#     my puts "<BODY>"
#     my puts "You Sent<p>"
#     my puts "<TABLE>"
#     foreach {f v} $form {
#       my puts "<TR><TH>$f</TH><TD><verbatim>$v</verbatim></TD>"
#     }
#     my puts "</TABLE><p>"
#     my puts "Send some info:<p>"
#     my puts "<FORM action=/[my request get REQUEST_PATH] method POST>"
#     my puts "<TABLE>"
#     foreach field {name rank serial_number} {
#       set line "<TR><TH>$field</TH><TD><input name=\"$field\" "
#       if {[dict exists $form $field]} {
#         append line " value=\"[dict get $form $field]\"""
#       }
#       append line " /></TD></TR>"
#       my puts $line
#     }
#     my puts "</TABLE>"
#     my puts [my html footer]
# 	}
# }
#
# }]
# [list_end]
###
::clay::define ::httpd::reply {
  superclass ::httpd::mime

  Variable transfer_complete 0

  Dict reply {}
................................................................................
  ###
  # clean up on exit
  ###
  destructor {
    my close
  }

  ###
  # Close channels opened by this object
  ###
  method close {} {
    my variable chan
    if {[info exists chan] && $chan ne {}} {
      catch {chan event $chan readable {}}
      catch {chan event $chan writable {}}
      catch {chan flush $chan}
      catch {chan close $chan}
      set chan {}
    }
  }

  ###
  # Record a dispatch event
  ###
  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] \
    ]
  }

  ###
  # Accept the handoff from the server object of the socket
  # [enph newsock] and feed it the state [emph datastate]
  #
  # Fields the [emph datastate] are looking for in particular are:
  #
  # mixin: A key/value list of slots and classes to be mixed into the
  # object prior to invoking [cmd Dispatch].
  #
  # http: A key/value list of values to populate the object's [emph request]
  # ensemble
  #
  # All other fields are passed along to the [emph clay] structure of the object.
  ###
  method dispatch {newsock datastate} {
    my variable chan request
    try {
      set chan $newsock
      chan event $chan readable {}
      chan configure $chan -translation {auto crlf} -buffering line
      if {[dict exists $datastate mixin]} {
................................................................................
  ###
  method content {} {
    my puts [my html_header {Hello World!}]
    my puts "<H1>HELLO WORLD!</H1>"
    my puts [my html_footer]
  }

  ###
  # Formulate a standard HTTP status header from he string provided.
  ###
  method EncodeStatus {status} {
    return "HTTP/1.0 $status"
  }

  method log {type {info {}}} {
    my variable dispatched_time uuid
    my <server> log $type $uuid $info
................................................................................
  method CoroName {} {
    if {[info coroutine] eq {}} {
      return ::httpd::object::[my clay get UUID]
    }
  }

  ###
  # Generates the the HTTP reply, streams that reply back across [arg chan],
  # and destroys the object.
  ###
  method DoOutput {} {
    my variable reply_body chan
    if {$chan eq {}} return
    catch {
      my wait writable $chan
      chan configure $chan  -translation {binary binary}
................................................................................
      }
      chan puts -nonewline $chan $result
      my log HttpAccess {}
    }
    my destroy
  }

  ###
  # For GET requests, converts the QUERY_DATA header into a key/value list.
  #
  # For POST requests, reads the Post data and converts that information to
  # a key/value list for application/x-www-form-urlencoded posts. For multipart
  # posts, it composites all of the MIME headers of the post to a singular key/value
  # list, and provides MIME_* information as computed by the [cmd mime] package, including
  # the MIME_TOKEN, which can be fed back into the mime package to read out the contents.
  ###
  method FormData {} {
    my variable chan formdata
    # Run this only once
    if {[info exists formdata]} {
      return $formdata
    }
    set length [my request get CONTENT_LENGTH]
................................................................................
          lappend formdata [my Url_Decode $name] [my Url_Decode $value]
        }
      }
    }
    return $formdata
  }

  # Stream [arg length] bytes from the [arg chan] socket, but only of the request is a
  # POST or PUSH. Returns an empty string otherwise.
  method PostData {length} {
    my variable postdata
    # Run this only once
    if {[info exists postdata]} {
      return $postdata
    }
    set postdata {}
................................................................................
    }
    return $postdata
  }

  # Manage session data
  method Session_Load {} {}



  # Intended to be invoked from [cmd {chan copy}] as a callback. This closes every channel
  # fed to it on the command line, and then destroys the object.
  #
  # [example {
  #     ###
  #     # Output the body
  #     ###
  #     chan configure $sock -translation binary -blocking 0 -buffering full -buffersize 4096
  #     chan configure $chan -translation binary -blocking 0 -buffering full -buffersize 4096
  #     if {$length} {
  #       ###
  #       # Send any POST/PUT/etc content
  #       ###
  #       chan copy $sock $chan -size $SIZE -command [info coroutine]
  #       yield
  #     }
  #     catch {close $sock}
  #     chan flush $chan
  # }]
  method TransferComplete args {
    my variable chan transfer_complete
    set transfer_complete 1
    my log TransferComplete
    set chan {}
    foreach c $args {
      catch {chan event $c readable {}}
................................................................................
      catch {chan event $c writable {}}
      catch {chan flush $c}
      catch {chan close $c}
    }
    my destroy
  }

  # Appends the value of [arg string] to the end of [arg reply_body], as well as a trailing newline
  # character.

  method puts line {
    my variable reply_body
    append reply_body $line \n
  }

  method RequestFind {field} {
    my variable request
................................................................................
      }
      default {
        error "Unknown command $subcommand. Valid: exists, get, getnull, output, replace, set"
      }
    }
  }

  # Clear the contents of the [arg reply_body] variable, and reset all headers in the [cmd reply]
  # structure back to the defaults for this object.

  method reset {} {
    my variable reply_body
    my reply replace    [my HttpHeaders_Default]
    my reply set Server [my <server> clay get server/ string]
    my reply set Date [my timestamp]
    set reply_body {}
  }

  # Called from the [cmd http::server] object which spawned this reply. Checks to see
  # if too much time has elapsed while waiting for data or generating a reply, and issues
  # a timeout error to the request if it has, as well as destroy the object and close the
  # [arg chan] socket.
  method timeOutCheck {} {
    my variable dispatched_time
    if {([clock seconds]-$dispatched_time)>120} {
      ###
      # Something has lasted over 2 minutes. Kill this
      ###
      catch {
................................................................................
        my error 408 {Request Timed out}
        my DoOutput
      }
    }
  }

  ###
  # Return the current system time in the format: [example {%a, %d %b %Y %T %Z}]
  ###
  method timestamp {} {
    return [clock format [clock seconds] -format {%a, %d %b %Y %T %Z}]
  }
}

###
# END: reply.tcl
###
###
# START: server.tcl
###
###
# An httpd server with a template engine and a shim to insert URL domains.

#
# This class is the root object of the webserver. It is responsible
# for opening the socket and providing the initial connection negotiation.
###
namespace eval ::httpd::object {}
namespace eval ::httpd::coro {}

::clay::define ::httpd::server {
  superclass ::httpd::mime

................................................................................
  clay set server/ myaddr 127.0.0.1
  clay set server/ string [list TclHttpd $::httpd::version]
  clay set server/ name [info hostname]
  clay set server/ doc_root {}
  clay set server/ reverse_dns 0
  clay set server/ configuration_file {}
  clay set server/ protocol {HTTP/1.1}


  clay set socket/ buffersize   32768
  clay set socket/ translation  {auto crlf}
  clay set reply_class ::httpd::reply

  Array template
  Dict url_patterns {}

  constructor {
  {args {
    port        {default auto      comment {Port to listen on}}
    myaddr      {default 127.0.0.1 comment {IP address to listen on. "all" means all}}
    string      {default auto      comment {Value for SERVER_SOFTWARE in HTTP headers}}
    name        {default auto      comment {Value for SERVER_NAME in HTTP headers. Defaults to [info hostname]}}
    doc_root    {default {}        comment {File path to serve.}}
    reverse_dns {default 0         comment {Perform reverse DNS to convert IPs into hostnames}}
    configuration_file {default {} comment {Configuration file to load into server namespace}}
    protocol    {default {HTTP/1.1} comment {Value for SERVER_PROTOCOL in HTTP headers}}
  }}} {
    if {[llength $args]==1} {
      set arglist [lindex $args 0]
    } else {
      set arglist $args
    }
    foreach {var val} $arglist {
      my clay set server/ $var $val
................................................................................
    my start
  }

  destructor {
    my stop
  }

  ###
  # Reply to an open socket. This method builds a coroutine to manage the remainder
  # of the connection. The coroutine's operations are driven by the [cmd Connect] method.
  ###
  method connect {sock ip port} {
    ###
    # If an IP address is blocked drop the
    # connection
    ###
    if {[my Validate_Connection $sock $ip]} {
      catch {close $sock}
................................................................................
    dict set result SERVER_SOFTWARE [my clay get server/ string]
    if {[string match 127.* $ip]} {
      dict set result LOCALHOST [expr {[lindex [split [dict getnull $result HTTP_HOST] :] 0] eq "localhost"}]
    }
    return $result
  }

  ###
  # This method reads HTTP headers, and then consults the [cmd dispatch] method to
  # determine if the request is valid, and/or what kind of reply to generate. Under
  # normal cases, an object of class [cmd ::http::reply] is created, and that class's
  # [cmd dispatch] method.
  # This action passes control of the socket to
  # the reply object. The reply object manages the rest of the transaction, including
  # closing the socket.
  ###
  method Connect {uuid sock ip} {
    yield [info coroutine]
    chan event $sock readable {}
    chan configure $sock \
      -blocking 0 \
      -translation {auto crlf} \
      -buffering line
................................................................................
      dict set reply template notfound
      dict set reply mixin reply ::httpd::content.template
    }
    set pageobj [::httpd::reply create ::httpd::object::$uuid [self]]
    tailcall $pageobj dispatch $sock $reply
  }

  # Increment an internal counter.
  method counter which {
    my variable counters
    incr counters($which)
  }

  ###
  # Check open connections for a time out event.
  ###
  method CheckTimeout {} {
    foreach obj [info commands ::httpd::object::*] {
      try {
        $obj timeOutCheck
      } on error {} {
        catch {$obj destroy}
................................................................................
      }
    }
  }

  method debug args {}

  ###
  # Given a key/value list of information, return a data structure describing how
  # the server should reply.
  ###
  method dispatch {data} {
    set reply [my Dispatch_Local $data]
    if {[dict size $reply]} {
      return $reply
    }
    return [my Dispatch_Default $data]
  }

  ###
  # Method dispatch method of last resort before returning a 404 NOT FOUND error.
  # The default behavior is to look for a file in [emph DOCUMENT_ROOT] which
  # matches the query.
  ###
  method Dispatch_Default {reply} {
    ###
    # Fallback to docroot handling
    ###
    set doc_root [dict getnull $reply http DOCUMENT_ROOT]
    if {$doc_root ne {}} {
      ###
................................................................................
      dict set reply path $doc_root
      dict set reply mixin reply httpd::content.file
      return $reply
    }
    return {}
  }

  ###
  # Method dispatch method invoked prior to invoking methods implemented by plugins.
  # If this method returns a non-empty dictionary, that structure will be passed to
  # the reply. The default is an empty implementation.
  ###
  method Dispatch_Local data {}

  ###
  # Introspect and possibly modify a data structure destined for a reply. This
  # method is invoked before invoking Header methods implemented by plugins.
  # The default implementation is empty.
  ###
  method Headers_Local {varname} {}

  ###
  # Introspect and possibly modify a data structure destined for a reply. This
  # method is built dynamically by the [cmd plugin] method.
  ###
  method Headers_Process varname {}

  ###
  # Convert an ip address to a host name. If the server/ reverse_dns flag
  # is false, this method simply returns the IP address back.
  # Internally, this method uses the [emph dns] module from tcllib.
  ###
  method HostName ipaddr {
    if {![my clay get server/ reverse_dns]} {
      return $ipaddr
    }
    set t [::dns::resolve $ipaddr]
    set result [::dns::name $t]
    ::dns::cleanup $t
    return $result
  }

  ###
  # Log an event. The input for args is free form. This method is intended
  # to be replaced by the user, and is a noop for a stock http::server object.
  ###
  method log args {
    # Do nothing for now
  }

  ###
  # Incorporate behaviors from a plugin.
  # This method dynamically rebuilds the [cmd Dispatch] and [cmd Headers]
  # method. For every plugin, the server looks for the following entries in
  # [emph "clay plugin/"]:
  # [para]
  # [emph load] - A script to invoke in the server's namespace during the [cmd plugin] method invokation.
  # [para]
  # [emph dispatch] - A script to stitch into the server's [cmd Dispatch] method.
  # [para]
  # [emph headers] - A script to stitch into the server's [cmd Headers] method.
  # [para]
  # [emph thread] - A script to stitch into the server's [cmd Thread_start] method.
  ###
  method plugin {slot {class {}}} {
    if {$class eq {}} {
      set class ::httpd::plugin.$slot
    }
    if {[info command $class] eq {}} {
      error "Class $class for plugin $slot does not exist"
    }
................................................................................
    }
    append body \n "\} on error \{err errdat\} \{"
    append body \n {  puts [list THREAD START ERROR [dict get $errdat -errorinfo]] ; return {}}
    append body \n "\}"
    oo::objdefine [self] method Thread_start {} $body
  }

  # Return the actual port that httpd is listening on.
  method port_listening {} {
    my variable port_listening
    return $port_listening
  }

  # For the stock version, trim trailing /'s and *'s from a prefix. This
  # method can be replaced by the end user to perform any other transformations
  # needed for the application.
  method PrefixNormalize prefix {
    set prefix [string trimright $prefix /]
    set prefix [string trimright $prefix *]
    set prefix [string trimright $prefix /]
    return $prefix
  }

  method source {filename} {
    source $filename
  }

  # Open the socket listener.
  method start {} {
    # Build a namespace to contain replies
    namespace eval [namespace current]::reply {}

    my variable socklist port_listening
    if {[my clay get server/ configuration_file] ne {}} {
      source [my clay get server/ configuration_file]
................................................................................
    } else {
      lappend socklist [socket -server [namespace code [list my connect]] $port]
    }
    ::cron::every [self] 120 [namespace code {my CheckTimeout}]
    my Thread_start
  }

  # Shut off the socket listener, and destroy any pending replies.
  method stop {} {
    my variable socklist
    if {[info exists socklist]} {
      foreach sock $socklist {
        catch {close $sock}
      }
    }
................................................................................
  Ensemble SubObject::db {} {
    return [namespace current]::Sqlite_db
  }
  Ensemble SubObject::default {} {
    return [namespace current]::$method
  }

  # Return a template for the string [arg page]
  method template page {
    my variable template
    if {[info exists template($page)]} {
      return $template($page)
    }
    set template($page) [my TemplateSearch $page]
    return $template($page)
  }

  # Perform a search for the template that best matches [arg page]. This
  # can include local file searches, in-memory structures, or even
  # database lookups. The stock implementation simply looks for files
  # with a .tml or .html extension in the [opt doc_root] directory.
  method TemplateSearch page {
    set doc_root [my clay get server/ doc_root]
    if {$doc_root ne {} && [file exists [file join $doc_root $page.tml]]} {
      return [::fileutil::cat [file join $doc_root $page.tml]]
    }
    if {$doc_root ne {} && [file exists [file join $doc_root $page.html]]} {
      return [::fileutil::cat [file join $doc_root $page.html]]
................................................................................
The page you are looking for: <b>[my request get REQUEST_URI]</b> does not exist.
[my html_footer]
        }
      }
    }
  }

  ###
  # Built by the [cmd plugin] method. Called by the [cmd start] method. Intended
  # to allow plugins to spawn worker threads.
  ###
  method Thread_start {} {}

  ###
  # Generate a GUUID. Used to ensure every request has a unique ID.
  # The default implementation is:
  # [example {
  #   return [::uuid::uuid generate]
  # }]
  ###
  method Uuid_Generate {} {
    return [::uuid::uuid generate]
  }

  ###
  # Given a socket and an ip address, return true if this connection should
  # be terminated, or false if it should be allowed to continue. The stock
  # implementation always returns 0. This is intended for applications to
  # be able to implement black lists and/or provide security based on IP
  # address.
  ###
  method Validate_Connection {sock ip} {
    return 0
  }
}

###
................................................................................
  clay set plugin/ dispatch {
    set reply [my Dispatch_Dict $data]
    if {[dict size $reply]} {
      return $reply
    }
  }

  ###
  # Implementation of the dispatcher
  ###
  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 {
................................................................................
        }
        return $buffer
      }
    }
    return {}
  }

  ###
  #
  Ensemble uri::add {vhosts patterns info} {
    my variable url_patterns
    foreach vhost $vhosts {
      foreach pattern $patterns {
        set data $info
        if {![dict exists $data prefix]} {
           dict set data prefix [my PrefixNormalize $pattern]

Changes to modules/httpd/httpd.test.

668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
Content-Length: [string length $checkfile]

$checkfile"
::httpd::test::compare $reply $checkreply
} {}

::DEBUG puts all-tests-finished

# -------------------------------------------------------------------------

testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End:







|








668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
Content-Length: [string length $checkfile]

$checkfile"
::httpd::test::compare $reply $checkreply
} {}

::DEBUG puts all-tests-finished
file delete [file join $DIR test.tcl]
# -------------------------------------------------------------------------

testsuiteCleanup

# Local variables:
# mode: tcl
# indent-tabs-mode: nil
# End: