1# httpd11.tcl --                                                -*- tcl -*-
2#
3#	A simple httpd for testing HTTP/1.1 client features.
4#	Not suitable for use on a internet connected port.
5#
6# Copyright (C) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
7#
8# See the file "license.terms" for information on usage and redistribution
9# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10
11package require Tcl 8.6-
12
13proc ::tcl::dict::get? {dict key} {
14    if {[dict exists $dict $key]} {
15        return [dict get $dict $key]
16    }
17    return
18}
19namespace ensemble configure dict \
20    -map [linsert [namespace ensemble configure dict -map] end get? ::tcl::dict::get?]
21
22proc make-chunk-generator {data {size 4096}} {
23    variable _chunk_gen_uid
24    if {![info exists _chunk_gen_uid]} {set _chunk_gen_uid 0}
25    set lambda {{data size} {
26        set pos 0
27        yield
28        while {1} {
29            set payload [string range $data $pos [expr {$pos + $size - 1}]]
30            incr pos $size
31            set chunk [format %x [string length $payload]]\r\n$payload\r\n
32            yield $chunk
33            if {![string length $payload]} {return}
34        }
35    }}
36    set name chunker[incr _chunk_gen_uid]
37    coroutine $name ::apply $lambda $data $size
38    return $name
39}
40
41proc get-chunks {data {compression gzip}} {
42    switch -exact -- $compression {
43        gzip     { set data [zlib gzip $data] }
44        deflate  { set data [zlib deflate $data] }
45        compress { set data [zlib compress $data] }
46    }
47
48    set data ""
49    set chunker [make-chunk-generator $data 512]
50    while {[string length [set chunk [$chunker]]]} {
51        append data $chunk
52    }
53    return $data
54}
55
56proc blow-chunks {data {ochan stdout} {compression gzip}} {
57    switch -exact -- $compression {
58        gzip     { set data [zlib gzip $data] }
59        deflate  { set data [zlib deflate $data] }
60        compress { set data [zlib compress $data] }
61    }
62
63    set chunker [make-chunk-generator $data 512]
64    while {[string length [set chunk [$chunker]]]} {
65        puts -nonewline $ochan $chunk
66    }
67    return
68}
69
70proc mime-type {filename} {
71    switch -exact -- [file extension $filename] {
72        .htm - .html { return {text text/html}}
73        .png { return {binary image/png} }
74        .jpg { return {binary image/jpeg} }
75        .gif { return {binary image/gif} }
76        .css { return {text   text/css} }
77        .xml { return {text   text/xml} }
78        .xhtml {return {text  application/xml+html} }
79        .svg { return {text image/svg+xml} }
80        .txt - .tcl - .c - .h { return {text text/plain}}
81    }
82    return {binary text/plain}
83}
84
85proc Puts {chan s} {puts $chan $s; puts $s}
86
87proc Service {chan addr port} {
88    chan event $chan readable [info coroutine]
89    while {1} {
90        set meta {}
91        chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
92        chan configure $chan -blocking 0
93        yield
94        while {[gets $chan line] < 0} {
95            if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
96            yield
97        }
98        if {[eof $chan]} {chan event $chan readable {}; close $chan; return}
99        foreach {req url protocol} {GET {} HTTP/1.1} break
100        regexp {^(\S+)\s+(.*)\s(\S+)?$} $line -> req url protocol
101
102        puts $line
103        while {[gets $chan line] > 0} {
104            if {[regexp {^([^:]+):(.*)$} $line -> key val]} {
105                puts [list $key [string trim $val]]
106                lappend meta [string tolower $key] [string trim $val]
107            }
108            yield
109        }
110
111        set encoding identity
112        set transfer ""
113        set close 1
114        set type text/html
115        set code "404 Not Found"
116        set data "<html><head><title>Error 404</title></head>"
117        append data "<body><h1>Not Found</h1><p>Try again.</p></body></html>"
118
119        if {[scan $url {%[^?]?%s} path query] < 2} {
120            set query ""
121        }
122
123        switch -exact -- $req {
124            GET - HEAD {
125            }
126            POST {
127                # Read the query.
128                set qlen [dict get? $meta content-length]
129                if {[string is integer -strict $qlen]} {
130                    chan configure $chan -buffering none -translation binary
131                    while {[string length $query] < $qlen} {
132                        append query [read $chan $qlen]
133                        if {[string length $query] < $qlen} {yield}
134                    }
135                    # Check for excess query bytes [Bug 2715421]
136                    if {[dict get? $meta x-check-query] eq "yes"} {
137                        chan configure $chan -blocking 0
138                        append query [read $chan]
139                    }
140                }
141            }
142            default {
143                # invalid request error 5??
144            }
145        }
146        if {$query ne ""} {puts $query}
147
148        set path [string trimleft $path /]
149        set path [file join [pwd] $path]
150        if {[file exists $path] && [file isfile $path]} {
151            foreach {what type} [mime-type $path] break
152            set f [open $path r]
153            if {$what eq "binary"} {chan configure $f -translation binary}
154            set data [read $f]
155            close $f
156            set code "200 OK"
157            set close [expr {[dict get? $meta connection] eq "close"}]
158        }
159
160        if {$protocol eq "HTTP/1.1"} {
161	    foreach enc [split [dict get? $meta accept-encoding] ,] {
162		set enc [string trim $enc]
163		if {$enc in {deflate gzip compress}} {
164		    set encoding $enc
165		    break
166		}
167	    }
168            set transfer chunked
169        } else {
170            set close 1
171        }
172
173        set nosendclose 0
174        foreach pair [split $query &] {
175            if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
176            switch -exact -- $key {
177                nosendclose  {set nosendclose 1}
178                close        {set close 1 ; set transfer 0}
179                transfer     {set transfer $val}
180                content-type {set type $val}
181            }
182        }
183        if {$protocol eq "HTTP/1.1"} {
184            set nosendclose 0
185        }
186
187        chan configure $chan -buffering line -encoding iso8859-1 -translation crlf
188        Puts $chan "$protocol $code"
189        Puts $chan "content-type: $type"
190        Puts $chan [format "x-crc32: %08x" [zlib crc32 $data]]
191        if {$req eq "POST"} {
192            Puts $chan [format "x-query-length: %d" [string length $query]]
193        }
194        if {$close && (!$nosendclose)} {
195            Puts $chan "connection: close"
196        }
197	Puts $chan "x-requested-encodings: [dict get? $meta accept-encoding]"
198        if {$encoding eq "identity" && (!$nosendclose)} {
199            Puts $chan "content-length: [string length $data]"
200        } elseif {$encoding eq "identity"} {
201            # This is a blatant attempt to confuse the client by sending neither
202            # "Connection: close" nor "Content-Length" when in non-chunked mode.
203            # See test http11-3.4.
204        } else {
205            Puts $chan "content-encoding: $encoding"
206        }
207        if {$transfer eq "chunked"} {
208            Puts $chan "transfer-encoding: chunked"
209        }
210        puts $chan ""
211        flush $chan
212
213        chan configure $chan -buffering full -translation binary
214        if {$transfer eq "chunked"} {
215            blow-chunks $data $chan $encoding
216        } elseif {$encoding ne "identity"} {
217            puts -nonewline $chan [zlib $encoding $data]
218        } else {
219            puts -nonewline $chan $data
220        }
221
222        if {$close} {
223            chan event $chan readable {}
224            close $chan
225            puts "close $chan"
226            return
227        } else {
228            flush $chan
229        }
230        puts "pipeline $chan"
231    }
232}
233
234proc Accept {chan addr port} {
235    coroutine client$chan Service $chan $addr $port
236    return
237}
238
239proc Control {chan} {
240    if {[gets $chan line] >= 0} {
241        if {[string trim $line] eq "quit"} {
242            set ::forever 1
243        }
244    }
245    if {[eof $chan]} {
246        chan event $chan readable {}
247    }
248}
249
250proc Main {{port 0}} {
251    set server [socket -server Accept -myaddr localhost $port]
252    puts [chan configure $server -sockname]
253    flush stdout
254    chan event stdin readable [list Control stdin]
255    vwait ::forever
256    close $server
257    return "done"
258}
259
260if {!$tcl_interactive} {
261    set r [catch [linsert $argv 0 Main] err]
262    if {$r} {puts stderr $errorInfo} elseif {[string length $err]} {puts $err}
263    exit $r
264}
265