tcl-hacks

Check-in [904a0d12e2]
Login

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

Overview
Comment:add minhttpd.tm: as tiny as a useful httpd module can be
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tclish-args
Files: files | file ages | folders
SHA1:904a0d12e2c3599ec4b275fb1950439cc1a0baf6
User & Date: aspect 2018-07-29 15:35:13
Context
2018-07-29
15:39
prove binary and utf-8 coding check-in: b1ecf5f008 user: aspect tags: tclish-args
15:35
add minhttpd.tm: as tiny as a useful httpd module can be check-in: 904a0d12e2 user: aspect tags: tclish-args
2018-07-28
05:55
simpler isatty check-in: b4e24a23f3 user: aspect tags: tclish-args
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to inet/inet.tcl.

256
257
258
259
260
261
262






















263
264
265
266
267
268
269
                        count or list of the particular product or product slot.  Vending
                        machines should NEVER NEVER EVER eat money.
                    } {puts $chan $line}
                }
            }
        }
    }























    service ident/113 { ;# rfc1413
        if {[gets $chan line] > 0} {
            set parts [lmap x [split $line ,] {string trim $x}]
            lassign $parts remote local

            if {![string is integer -strict $local] || $local < 1 || $local >= 2**16} {







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







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
                        count or list of the particular product or product slot.  Vending
                        machines should NEVER NEVER EVER eat money.
                    } {puts $chan $line}
                }
            }
        }
    }

    service http/80 {   ;# rfc2616 - see minhttpd for a much more careful implementation

        chan configure $chan -encoding iso8859-1 -translation crlf

        gets $chan reqline

        if {![regexp {^GET (\S+) HTTP/1.1$} $reqline -> uri]} {
            puts $chan "HTTP/1.1 400 Bad Request"
            puts $chan "Connection: close"
            puts $chan ""
            throw {HTTP INVALID REQUEST} "Invalid request [list $reqline]"
        }

        while {[gets $chan line]>0} {}

        puts $chan "HTTP/1.1 200 OK"
        puts $chan "Connection: close"
        puts $chan ""
        puts $chan "Hello, world!"
    }


    service ident/113 { ;# rfc1413
        if {[gets $chan line] > 0} {
            set parts [lmap x [split $line ,] {string trim $x}]
            lassign $parts remote local

            if {![string is integer -strict $local] || $local < 1 || $local >= 2**16} {

Added modules/minhttpd-0.tm.

































































































































































































































































































































































































>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
#!/usr/bin/env tclsh
#
# Just the bare minimum to serve http.  See example at bottom.
#

namespace eval minhttpd {

    proc callback args {
        tailcall namespace code $args
    }
    proc finally args {
        set ns [uplevel 1 {namespace current}]
        set callback [list apply [list args $args $ns]]
        tailcall trace add variable :#:FINALLY:#: unset $callback
    }

    # an async gets that *must* consume a line + newline, and will reject lines > limit chars long
    proc http-gets {chan _line {limit 1024}} {
        upvar 1 $_line line
        while 1 {
            yield
            if {[gets $chan line] >= 0 && ![eof $chan]} break   ;# EOF will be true if we didn't get a line-terminator
            if {[chan pending input $chan] > $limit} {
                return -level 2 -code error -errorcode {MINHTTPD LINE_TOO_LONG} "Line too long: [chan pending $chan] > $limit bytes"
            }
            if {[eof $chan]} {
                return -level 2 -code error -errorcode {MINHTTPD EOF} "Premature EOF while reading line after [string length $line] bytes"
            }
        }
    }

    proc serve {callback port args} {
        dict set sockargs -server [callback accept $callback]
        if {[regexp {(.*):(.*)} $port -> host port]} {
            dict set sockargs -myaddr $host
        }
        set listenfd [socket {*}$sockargs $port]
        return $listenfd
    }

    proc accept {callback chan caddr cport} {
        coroutine coro#$chan#[info cmdcount] Accept $callback $chan
    }

    proc Accept {callback chan} {
        finally close $chan

        set timeout [after 1000 [list rename [info coroutine] {}]]
        finally after cancel $timeout

        chan configure $chan -translation crlf -encoding iso8859-1 -blocking 0
        chan event $chan readable [info coroutine]

        http-gets $chan reqline

        if {![regexp {^GET (.*) HTTP/1.\d+$} $reqline -> uri]} {
            puts $chan "HTTP/1.1 400 Bad Request"
            puts $chan "Connection: close"
            puts $chan ""
            return -code error -errorcode {MINHTTPD INVALID REQUEST} "Invalid request [list $reqline]"
        }

        while 1 {
            http-gets $chan header
            if {$header eq ""} break
        }

        regsub {^https?://[^/]*} $uri {} uri

        set rc [catch {uplevel #0 [list {*}$callback $uri]} res opts]

        if {$rc == 0} {
            set code 200
            set data $res
        } elseif {$rc < 100} {
            set code 500
            set data ""
        } else {
            set code $rc
            set data $res
            set rc 0
        }

        if {$code in {301 302}} {
            if {![dict exists $opts -location]} {
                if {$res eq ""} {
                    throw {MINHTTPD BAD REDIRECT} "Redirect must specify -location or a result"
                } else {
                    dict set opts -location $res
                    set res ""
                }
            }
            set data $res
        }

        dict unset opts -level
        dict unset opts -code
        foreach errkey [dict keys $opts -error*] {
            dict unset opts $errkey
        }

        set httpcodes {
            200 "OK"
            204 "No Content"
            301 "Moved Permanently"
            302 "Found"
            403 "Forbidden"
            404 "Not Found"
            500 "Internal Server Error"
        }
        set codedesc [dict get $httpcodes $code]

        if {$data eq ""} {
            if {$code eq 200} {set code 204}
            if {$code ne 204} {set data $codedesc}
        }

        puts $chan "HTTP/1.1 $code $codedesc"
        puts $chan "Connection: close"

        set defheaders {
            -content-type text/html
        }

        set headers [dict merge $defheaders $opts]

        set is_text [string match text/* [dict get $headers -content-type]]

        if {$is_text} {
            dict append headers -content-type "; charset=utf-8"
        }

        if {$data eq ""} {
            dict unset headers -content-type
        }

        dict for {header value} $headers {
            regsub ^- $header {} header
            regsub :$ $header {} header
            regsub -all "\n\\s*" $value "\n "
            puts $chan "$header: $value"
        }
        puts $chan ""

        if {!$is_text} {
            chan configure $chan -translation binary
            puts -nonewline $chan $data
        } else {
            chan configure $chan -encoding utf-8
            if {$data ne ""} {
                puts $chan $data        ;# extra newline for friendliness
            }
        }

        # finally will close $chan

        if {$rc != 0} {
            return -code $rc {*}$opts $res
        }
    }
}

if {[info script] eq $::argv0} {

    set svrfd [minhttpd::serve httpGet 8080]

    proc httpGet {url} {
        if {$url eq "/"} {
            return -code 302 /index.html
        }
        if {$url eq "/admin"} {
            return -code 403 "You are not allowed!"
        }
        if {$url eq "/index.html"} {
            return "Hello, world!"
        }
        if {$url eq "/exit"} {
            after idle {incr ::forever}
            return "Exiting!"
        }
        if {$url eq "/empty"} {
            return ""
        }
        if {$url eq "/error"} {
            expr {1/0}
        }
        return -code 404
    }

    vwait forever

}