Tcl Library Source Code

Check-in [8a1de41126]
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 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
Timelines: family | ancestors | descendants | both | hypnotoad
Files: files | file ages | folders
SHA3-256:8a1de411266a7766817b62b1a5c89fbf1219c57c65c3003a6018d49cf7b0b279
User & Date: hypnotoad 2018-09-13 15:31:00
Context
2018-09-15
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
2018-09-12
20:23
Modifications to httpd: Refactored the ChanCopy method to utilize the yieldto command, per a suggestion from Donal Fellows. check-in: bbdea9cd0c user: hypnotoad tags: hypnotoad
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

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

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
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    my log SendReply [list length $length]
    if {$length} {
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }

  ###
  # For most CGI applications a directory list is vorboten
  ###
  method DirectoryListing {local_file} {
    my error 403 {Not Allowed}
    tailcall my DoOutput
  }
}







<
<
|
|
|
|
|
|
<










114
115
116
117
118
119
120


121
122
123
124
125
126

127
128
129
130
131
132
133
134
135
136
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }

  ###
  # For most CGI applications a directory list is vorboten
  ###
  method DirectoryListing {local_file} {
    my error 403 {Not Allowed}
    tailcall my DoOutput
  }
}

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

129
130
131
132
133
134
135



136
137
138
139
140
141
142
      ###
      set size [file size $reply_file]
      my reply set Content-Length $size
      append result [my reply output] \n
      chan puts -nonewline $chan $result
      set reply_chan [open $reply_file r]
      my log SendReply [list length $size]



      chan configure $reply_chan -translation {binary binary}
      my ChannelCopy $reply_chan $chan -size $size
    } finally {
      my TransferComplete $reply_chan $chan
    }
  }
}







>
>
>
|
|





129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
      ###
      set size [file size $reply_file]
      my reply set Content-Length $size
      append result [my reply output] \n
      chan puts -nonewline $chan $result
      set reply_chan [open $reply_file r]
      my log SendReply [list length $size]
      ###
      # Output the file contents. With no -size flag, channel will copy until EOF
      ###
      chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0
      my ChannelCopy $reply_chan $chan -chunk 4096
    } finally {
      my TransferComplete $reply_chan $chan
    }
  }
}

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

134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
    # Read the first incoming line as the HTTP reply status
    # Return the rest of the headers verbatim
    ###
    set replybuffer "$reply_status\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    if {[dict exists $replydat Content-Length]} {
      set length [dict get $replydat Content-Length]
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }

  method Dispatch {} {
    my variable sock chan
    if {[catch {my proxy_channel} sock errdat]} {
      my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo]
      tailcall my DoOutput







<
<
|
|
|
|
|
|
<







134
135
136
137
138
139
140


141
142
143
144
145
146

147
148
149
150
151
152
153
    # Read the first incoming line as the HTTP reply status
    # Return the rest of the headers verbatim
    ###
    set replybuffer "$reply_status\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }

  method Dispatch {} {
    my variable sock chan
    if {[catch {my proxy_channel} sock errdat]} {
      my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo]
      tailcall my DoOutput

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

94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
          }
        }
      }
      my Session_Load
      my Log_Dispatched
      my Dispatch
    } on error {err errdat} {
      puts [list ERROR ***]
      puts [dict get $errdat -errorinfo]
      puts [list ***]
      my error 500 $err [dict get $errdat -errorinfo]
      my DoOutput
    }
  }

  method Dispatch {} {
    # Invoke the URL implementation.







<
<
<







94
95
96
97
98
99
100



101
102
103
104
105
106
107
          }
        }
      }
      my Session_Load
      my Log_Dispatched
      my Dispatch
    } on error {err errdat} {



      my error 500 $err [dict get $errdat -errorinfo]
      my DoOutput
    }
  }

  method Dispatch {} {
    # Invoke the URL implementation.

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

79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    if {[dict exists $replydat Content-Length]} {
      set length [dict get $replydat Content-Length]
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }
}

###
# Act as an  SCGI Server
###
::clay::define ::httpd::server.scgi {







<
<
|
|
|
|
|
|
<







79
80
81
82
83
84
85


86
87
88
89
90
91

92
93
94
95
96
97
98
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }
}

###
# Act as an  SCGI Server
###
::clay::define ::httpd::server.scgi {

Changes to modules/httpd/httpd.tcl.

416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
....
1393
1394
1395
1396
1397
1398
1399



1400
1401
1402
1403
1404
1405
1406
1407
1408
....
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
....
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
....
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
          }
        }
      }
      my Session_Load
      my Log_Dispatched
      my Dispatch
    } on error {err errdat} {
      puts [list ERROR ***]
      puts [dict get $errdat -errorinfo]
      puts [list ***]
      my error 500 $err [dict get $errdat -errorinfo]
      my DoOutput
    }
  }

  method Dispatch {} {
    # Invoke the URL implementation.
................................................................................
      ###
      set size [file size $reply_file]
      my reply set Content-Length $size
      append result [my reply output] \n
      chan puts -nonewline $chan $result
      set reply_chan [open $reply_file r]
      my log SendReply [list length $size]



      chan configure $reply_chan -translation {binary binary}
      my ChannelCopy $reply_chan $chan -size $size
    } finally {
      my TransferComplete $reply_chan $chan
    }
  }
}

###
................................................................................
    # Read the first incoming line as the HTTP reply status
    # Return the rest of the headers verbatim
    ###
    set replybuffer "$reply_status\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    if {[dict exists $replydat Content-Length]} {
      set length [dict get $replydat Content-Length]
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }

  method Dispatch {} {
    my variable sock chan
    if {[catch {my proxy_channel} sock errdat]} {
      my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo]
      tailcall my DoOutput
................................................................................
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    my log SendReply [list length $length]
    if {$length} {
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }

  ###
  # For most CGI applications a directory list is vorboten
  ###
  method DirectoryListing {local_file} {
    my error 403 {Not Allowed}
................................................................................
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer
    if {[dict exists $replydat Content-Length]} {
      set length [dict get $replydat Content-Length]
      ###
      # Output the body
      ###
      chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
      chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
      my ChannelCopy $chana $chanb -size $length
    }
  }
}

###
# Act as an  SCGI Server
###
::clay::define ::httpd::server.scgi {







<
<
<







 







>
>
>
|
|







 







<
<
|
|
|
|
|
|
<







 







<
<
|
|
|
|
|
|
<







 







<
<
|
|
|
|
|
|
<







416
417
418
419
420
421
422



423
424
425
426
427
428
429
....
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
....
1547
1548
1549
1550
1551
1552
1553


1554
1555
1556
1557
1558
1559

1560
1561
1562
1563
1564
1565
1566
....
1703
1704
1705
1706
1707
1708
1709


1710
1711
1712
1713
1714
1715

1716
1717
1718
1719
1720
1721
1722
....
1811
1812
1813
1814
1815
1816
1817


1818
1819
1820
1821
1822
1823

1824
1825
1826
1827
1828
1829
1830
          }
        }
      }
      my Session_Load
      my Log_Dispatched
      my Dispatch
    } on error {err errdat} {



      my error 500 $err [dict get $errdat -errorinfo]
      my DoOutput
    }
  }

  method Dispatch {} {
    # Invoke the URL implementation.
................................................................................
      ###
      set size [file size $reply_file]
      my reply set Content-Length $size
      append result [my reply output] \n
      chan puts -nonewline $chan $result
      set reply_chan [open $reply_file r]
      my log SendReply [list length $size]
      ###
      # Output the file contents. With no -size flag, channel will copy until EOF
      ###
      chan configure $reply_chan -translation {binary binary} -buffersize 4096 -buffering full -blocking 0
      my ChannelCopy $reply_chan $chan -chunk 4096
    } finally {
      my TransferComplete $reply_chan $chan
    }
  }
}

###
................................................................................
    # Read the first incoming line as the HTTP reply status
    # Return the rest of the headers verbatim
    ###
    set replybuffer "$reply_status\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }

  method Dispatch {} {
    my variable sock chan
    if {[catch {my proxy_channel} sock errdat]} {
      my error 504 {Service Temporarily Unavailable} [dict get $errdat -errorinfo]
      tailcall my DoOutput
................................................................................
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }

  ###
  # For most CGI applications a directory list is vorboten
  ###
  method DirectoryListing {local_file} {
    my error 403 {Not Allowed}
................................................................................
    # a standard service reply line from a web server, but
    # otherwise spit out the rest of the headers verbatim
    ###
    set replybuffer "HTTP/1.0 [dict get $replydat Status]\n"
    append replybuffer $replyhead
    chan configure $chanb -translation {auto crlf} -blocking 0 -buffering full -buffersize 4096
    chan puts $chanb $replybuffer


    ###
    # Output the body. With no -size flag, channel will copy until EOF
    ###
    chan configure $chana -translation binary -blocking 0 -buffering full -buffersize 4096
    chan configure $chanb -translation binary -blocking 0 -buffering full -buffersize 4096
    my ChannelCopy $chana $chanb -chunk 4096

  }
}

###
# Act as an  SCGI Server
###
::clay::define ::httpd::server.scgi {