-
Notifications
You must be signed in to change notification settings - Fork 0
/
wibble.tcl
993 lines (903 loc) · 35.7 KB
/
wibble.tcl
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
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
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
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
959
960
961
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
#!/usr/bin/env tclsh
# Wibble - a pure-Tcl Web server. http://wiki.tcl.tk/23626
# Copyright 2011 Andy Goth. mailto/andrew.m.goth/at/gmail/dot/com
# Available under the Tcl/Tk license. http://tcl.tk/software/tcltk/license.html
package require Tcl 8.6
package provide wibble 0.1
# Define the wibble namespace.
namespace eval ::wibble {
variable zonehandlers
}
# ============================== zone handlers ================================
# Echo request dictionary.
proc ::wibble::vars {state} {
dict set response status 200
dict set response header content-type text/html
dict set response content "<html><head><style type=\"text/css\">\
body {font-family: monospace}\
table {border-collapse: collapse; outline: 1px solid #000}\
th {white-space: nowrap; text-align: left}\
th, td {border: 1px solid #727772}\
tr:nth-child(odd) {background-color: #ded}\
tr:nth-child(even) {background-color: #eee}\
th.title {background-color: #8d958d; text-align: center}\
</style></head><body><table>"
foreach {dictname dictval} $state {
if {$dictname eq "request"} {
set dictval [dumprequest $dictval]
}
dict append response content\
"<tr><th class=\"title\" colspan=\"2\">[enhtml $dictname]</th></tr>"
foreach {key val} $dictval {
dict append response content\
<tr><th>[enhtml $key]</th><td>[enhtml $val]</td></tr>
}
}
dict append response content </table></body></html>
sendresponse $response
}
# Redirect when a directory is requested without a trailing slash.
proc ::wibble::dirslash {state} {
dict with state request {}; dict with state options {}
if {[file isdirectory $fspath] && [string index $suffix end] ni {/ ""}} {
append path /
if {[info exists rawquery]} {
append path $rawquery
}
redirect $path
}
}
# Rewrite directory requests to search for an indexfile.
proc ::wibble::indexfile {state} {
dict with state request {}; dict with state options {}
if {[file isdirectory $fspath]} {
if {[string index $path end] ne "/"} {
append path /
}
set newstate $state
dict set state request path $path$indexfile
nexthandler $newstate $state
}
}
# Generate directory listings.
proc ::wibble::dirlist {state} {
dict with state request {}; dict with state options {}
if {![file isdirectory $fspath]} {
# Pass if the requested object is not a directory or doesn't exist.
} elseif {[file readable $fspath]} {
# If the directory is readable, generate a listing.
dict set response status 200
dict set response header content-type text/html
dict set response content <html><body>
dict append response content "<a href=\"..\">..</a><br />\n"
foreach elem [lsort [glob -nocomplain -tails -directory $fspath *]] {
dict append response content\
"<a href=\"[enurl $elem]\">[enhtml $elem]</a><br />\n"
}
dict append response content </body></html>\n
sendresponse $response
} else {
# But if it isn't readable, generate a 403.
forbidden $state
}
}
# Compile templates into scripts.
proc ::wibble::template {state} {
dict with state request {}; dict with state options {}
if {[file readable $fspath.tmpl] && (![file readable $fspath.script]
|| [file mtime $fspath.script] < [file mtime $fspath.tmpl])} {
set chan [open $fspath.tmpl]
set tmpl [read $chan]
chan close $chan
set chan [open $fspath.script w]
chan puts -nonewline $chan\
[compiletemplate "dict append response content" $tmpl]
chan close $chan
}
}
# Execute scripts.
proc ::wibble::script {state} {
dict with state request {}; dict with state options {}
if {[file readable $fspath.script]} {
dict set response status 200
dict set response header content-type text/plain
dict set response content ""
source $fspath.script
sendresponse $response
}
}
# Send static files.
proc ::wibble::static {state} {
dict with state request {}; dict with state options {}
if {![file isdirectory $fspath] && [file exists $fspath]} {
dict set response status 200
dict set response contentfile $fspath
sendresponse $response
}
}
# Send a 301 Moved Permanently.
proc ::wibble::redirect {newurl {state ""}} {
dict set response status 301
dict set response header location $newurl
sendresponse $response
}
# Send a 403 Forbidden.
proc ::wibble::forbidden {state} {
dict set response status 403
dict set response header content-type text/plain
dict set response content "forbidden: [dict get $state request uri]\n"
sendresponse $response
}
# Send a 404 Not Found.
proc ::wibble::notfound {state} {
dict set response status 404
dict set response header content-type text/plain
dict set response content "not found: [dict get $state request uri]\n"
sendresponse $response
}
# ============================ utility procedures =============================
# Compile a template.
proc ::wibble::compiletemplate {command template} {
set script ""
set pos 0
foreach match [regexp -line -all -inline -indices {^%.*$} $template] {
lassign $match from to
set str [string range $template $pos [expr {$from - 2}]]
if {$str ne ""} {
append script "$command \[[list subst $str\n]\]\n"
}
append script [string range $template [expr {$from + 1}] $to]\n
set pos [expr {$to + 2}]
}
set str [string range $template $pos end]
if {$str ne ""} {
append script "$command \[[list subst $str]\]"
}
string trimright $script
}
# Flatten the request dictionary into a form that's easier to log.
proc ::wibble::dumprequest {data {prefix ""}} {
if {![llength $data]} {
return [list $prefix ""]
}
set result {}
foreach {key val} $data {
set key [concat $prefix [list $key]]
if {$key in {header "header content-type" "header cookie" accept query}
|| ([lindex $key 0] in {post query} && ([llength $key] < 3
|| ([llength $key] == 3 && [lindex $key 2] ne "")))} {
lappend result {*}[dumprequest $val $key]
} elseif {[string length $val] > 512} {
lappend result $key (len=[string length $val])
} else {
lappend result $key $val
}
}
return $result
}
# ========================= network input procedures ==========================
# Get a line of data from the current coroutine's socket.
proc ::wibble::getline {} {
set socket [namespace tail [info coroutine]]
while {1} {
if {[chan gets $socket line] >= 0} {
return $line
} elseif {[chan eof $socket]} {
return -level [info level]
} elseif {[chan pending input $socket] > 4096} {
error "line length exceeds limit of 4096 bytes"
}
icc get [info coroutine] readable
}
}
# Get a block of data from the current coroutine's socket.
proc ::wibble::getblock {size} {
set socket [namespace tail [info coroutine]]
while {1} {
set chunklet [chan read $socket $size]
set size [expr {$size - [string length $chunklet]}]
append chunk $chunklet
if {[chan eof $socket]} {
return -level [info level]
} elseif {$size == 0} {
return $chunk
}
icc get [info coroutine] readable
}
}
# ==================== conversion and parsing procedures ======================
# Encode for HTML by substituting angle brackets, ampersands, line breaks, and
# space sequences.
proc ::wibble::enhtml {str} {
string map {< < > > & & \r "" \n "<br />\n" " " \ &\#160;} $str
}
# Encode for HTML tag attribute by substituting angle brackets, ampersands,
# double quotes, and space sequences.
proc ::wibble::enattr {str} {
string map {< < > > & & \r "" \n "" \" " " " \ &\#160;} $str
}
# Encode for HTML <pre> by substituting angle brackets and ampersands.
proc ::wibble::enpre {str} {
string map {< < > > & & \r ""} $str
}
# Encode a query string. The caller must prepend the question mark.
proc ::wibble::enquery {args} {
set query {}
foreach {key val} [concat {*}$args] {
if {[dict exists $val ""]} {
lappend query [enurl $key]=[enurl [dict get $val ""]]
} else {
lappend query [enurl $key]
}
}
join $query &
}
# Decode a query string into a list. The caller must strip the question mark.
proc ::wibble::dequery {str} {
set query {}
foreach elem [split $str &] {
regexp {^([^=]*)(?:(=.*))?$} $elem _ key val
if {$val ne ""} {
set val [list "" [deurl [string range $val 1 end]]]
}
lappend query [deurl $key] $val
}
return $query
}
# Encode by substituting most non-alphanumerics with hexadecimal codes.
proc ::wibble::enhex {str} {
set pos 0
while {[regexp -indices -start $pos {[^-^,./'=+|!$\w]} $str range]} {
binary scan [string range $str {*}$range] H2 char
set str [string replace $str {*}$range %$char]
set pos [expr {[lindex $range 0] + 3}]
}
return $str
}
# Decode hexadecimal encoding.
proc ::wibble::dehex {str} {
set pos 0
while {[regexp -indices -start $pos {%([[:xdigit:]]{2})} $str range code]} {
set char [binary format H2 [string range $str {*}$code]]
set str [string replace $str {*}$range $char]
set pos [expr {[lindex $range 0] + 1}]
}
return $str
}
# Encode for URLs by substituting plus, space, and most other non-alphanumerics.
proc ::wibble::enurl {str} {
enhex [string map {+ %2b " " +} $str]
}
# Decode URL encoding.
proc ::wibble::deurl {str} {
dehex [string map {+ " "} $str]
}
# Decode header list encoding.
proc ::wibble::delist {separator str} {
regexp -all -inline [dict get {
semicolon {"(?:[^\\"]|\\.)*"|\((?:[^\\()]|\\.)*\)|[^;]+}
comma {"(?:[^\\"]|\\.)*"|\((?:[^\\()]|\\.)*\)|[^,]+}
semicomma {"(?:[^\\"]|\\.)*"|\((?:[^\\()]|\\.)*\)|[^,;]+}
space {"(?:[^\\"]|\\.)*"|\((?:[^\\()]|\\.)*\)|[^"()\\\s]+}
} $separator] $str
}
# Decode header quoting.
proc ::wibble::dequote {str} {
if {([string index $str 0] eq "\"" && [string index $str end] eq "\"")
|| ([string index $str 0] eq "(" && [string index $str end] eq ")")} {
regsub -all {\\(.)} [string range $str 1 end-1] {\1}
} else {
return $str
}
}
# Decode headers.
proc ::wibble::deheader {str} {
set header {}
foreach {_ key raw} [regexp -all -inline -expanded -lineanchor {
^( [^\s:]+ ) \s*:\s*
( (?: "(?:[^\\"]|\\.)*" | \((?:[^\\()]|\\.)*\) | [^\n] | \n[ \t] )* )
} $str] {
set key [string tolower $key]
set raw [string trim $raw]
set val {}
switch $key {
cookie {
# Value is a cookie definition.
set common {}
set cookie ""
foreach elem [delist semicomma $raw] {
regexp {\s*([^\s=]*)(?:\s*=(.*))?} $elem _ key2 val2
set key2 [string tolower $key2]
if {[string index $key2 0] eq "\$"} {
set key2 [dehex [string range $key2 1 end]]
if {$cookie eq ""} {
dict set common $key2 [dehex $val2]
} else {
dict set params $key2 [dehex $val2]
}
} else {
if {$cookie ne ""} {
lappend val $cookie $params
}
set cookie [dehex $key2]
set params $common
dict set params "" [dehex $val2]
}
}
if {$cookie ne ""} {
lappend val $cookie $params
}
} cache-control - pragma {
# Value has format "subkey1=subval1,subkey2=subval2".
foreach elem [delist comma $raw] {
regexp {\s*([^\s=]+)(?:\s*(=.*))?} $elem _ key2 val2
if {$val2 ne ""} {
set val2 [dequote [string trim [string range $val2 1 end]]]
set val2 [list "" $val2]
}
lappend val [string tolower $key2] $val2
}
} connection - content-encoding - content-language - if-match -
if-none-match - trailer - upgrade - vary - via - warning {
# Value has format "elem1,elem2".
foreach elem [delist comma $raw] {
lappend val [dequote [string trim $elem]]
}
} accept - accept-charset - accept-encoding - accept-language -
expect - te - transfer-encoding {
# Value has format "elem1;subkey1=subval1;subkey2=subval2,elem2".
foreach elem [delist comma $raw] {
set params {}
set subs [delist semicolon $elem]
foreach sub [lrange $subs 1 end] {
regexp {\s*([^\s=]+)(?:\s*=\s*(.*?)\s*)?} $sub _ key2 val2
lappend params [string tolower $key2] [dequote $val2]
}
lappend val [string tolower [string trim [lindex $subs 0]]]
lappend val $params
}
} content-disposition - content-type {
# Value has format "elem;subkey1=subval1;subkey2=subval2".
set elems [delist semicolon $raw]
set val [list "" [string tolower [lindex $elems 0]]]
foreach elem [lrange $elems 1 end] {
regexp {\s*([^\s=]+)(?:\s*=\s*(.*?)\s*)?} $elem _ key2 val2
lappend val [string tolower $key2] [dequote $val2]
}
} user-agent {
# Value is a user-agent definition.
foreach elem [delist space $raw] {
if {[string index $elem 0] eq "("} {
lappend val ([dequote $elem])
} else {
lappend val [dequote $elem]
}
}
} default {
# Value has format "elem".
set val $raw
}}
dict set header $key $val
}
return $header
}
# =================== inter-coroutine communication system ====================
# The inter-coroutine communication procedures are in the [icc] ensemble.
namespace eval ::wibble::icc {
namespace export configure get put
namespace ensemble create
variable feeds
}
# Lapse (remove) a feed that nothing's interested in anymore.
proc ::wibble::icc::lapse {fid} {
variable feeds
# Clean up the feed's data structures.
set lapsescript [dict get $feeds $fid lapsescript]
dict unset feeds $fid
# Run the lapse script, which may be empty string.
uplevel #0 $lapsescript
}
# Adjust an ICC feed's configuration, creating the feed in the process.
# [icc configure $fid accept|reject ?filter? ?...?]
# [icc configure $fid lapse ?timeout_milliseconds? ?lapsescript?]
proc ::wibble::icc::configure {fid operation args} {
variable feeds
# Initialize the feed if it doesn't already exist.
if {![info exists feeds] || ![dict exists $feeds $fid]} {
dict set feeds $fid {acceptable "" lapsetime "" lapsescript ""
lapsecancel "" suspended "" pending ""}
}
# Reset the feed's lapse timeout.
if {[dict get $feeds $fid lapsecancel] ne ""} {
after cancel [dict get $feeds $fid lapsecancel]
dict set feeds $fid lapsecancel ""
}
# Process the requested operation.
switch $operation {
lapse {
# Store arguments into feed structure, defaulting to "".
dict set feeds $fid lapsetime [lindex $args 0]
dict set feeds $fid lapsescript [lindex $args 1]
} accept {
# Append the arguments to the list of accepted filters.
dict set feeds $fid acceptable [concat\
[dict get $feeds $fid acceptable] $args]
} reject {
# Remove all filters that match any of the argument patterns.
set index 0
foreach filter [dict get $feeds $fid acceptable] {
foreach pattern $args {
if {[string match $pattern $filter]} {
dict set feeds $fid acceptable [lreplace\
[dict get $feeds $fid acceptable] $index $index]
incr index -1
break
}
}
incr index
}
}}
# Restart the feed's lapse timeout.
if {[dict get $feeds $fid lapsetime] ne ""} {
dict set feeds $fid lapsecancel [after [dict get $feeds $fid lapsetime]\
[list ::wibble::icc::lapse $fid]]
}
}
# Get a list of events on one or more feeds matching any of the filters.
proc ::wibble::icc::get {fids filters {timeout ""}} {
variable feeds
# Reset the feed lapse timeouts, and check for pending events.
set result {}
set index 0
foreach fid $fids {
# Reset the feed's lapse timeout.
if {[dict get $feeds $fid lapsecancel] ne ""} {
after cancel [dict get $feeds $fid lapsecancel]
dict set feeds $fid lapsecancel ""
}
# Gather the pending events that match the request filters.
foreach entry [dict get $feeds $fid pending] {
foreach filter $filters {
if {[string match $filter [lindex $entry 0]]} {
dict set feeds $fid pending [lreplace\
[dict get $feeds $fid pending] $index $index]
lappend result $entry
incr index -1
break
}
}
incr index
}
}
# If no acceptable events were pending, wait for one to occur.
if {![llength $result]} {
# Install wake-up handlers for readability and timeout, as requested.
set coro [info coroutine]
set socket [namespace tail $coro]
if {[set readable [expr {"readable" in $filters && $coro in $fids}]]} {
chan event $socket readable [list $coro readable]
}
if {$timeout ne ""} {
lappend filters timeout
if {$coro ni $fids} {
lappend fids $coro
}
set timeoutcancel [after $timeout [list $coro timeout]]
}
# Wait for an event. Maintain each feed's list of suspended coroutines.
foreach fid $fids {
dict set feeds $fid suspended $coro $filters
}
set result [list [yield]]
foreach fid $fids {
dict unset feeds $fid suspended $coro
}
# Remove the readability and timeout handlers.
if {$timeout ne "" && [lindex $result 0 0] ne "timeout"} {
after cancel $timeoutcancel
}
if {$readable} {
chan event $socket readable ""
}
}
# Restart the lapse timeouts for the feeds monitored by this coroutine.
foreach fid $fids {
if {[dict get $feeds $fid lapsetime] eq ""} {continue}
if {[dict get $feeds $fid lapsecancel] ne ""} {
after cancel [dict get $feeds $fid lapsecancel]
}
dict set feeds $fid lapsecancel [after [dict get $feeds $fid lapsetime]\
[list ::wibble::icc::lapse $fid]]
}
# Return the event data.
return $result
}
# Send event data to the named feeds, or all if "*".
proc ::wibble::icc::put {fids event args} {
variable feeds
# Expand "*" to a list of all feeds that exist at the time [put] is called.
if {$fids eq "*"} {
set fids [dict keys $feeds]
}
# Insist on running from the event loop, never from within a coroutine.
if {[info coroutine] ne ""} {
after 0 [concat [list ::wibble::icc::put $fids $event] $args]
return
}
# Send the event to all feeds whose filters accept it.
set argument [concat [list $event] $args]
foreach fid $fids {
if {![dict exists $feeds $fid]} {continue}
foreach filter [dict get $feeds $fid acceptable] {
if {![string match $filter $event]} {continue}
# Send event to a suspended coroutine watching the feed.
set found 0
dict for {coro filters} [dict get $feeds $fid suspended] {
foreach filter $filters {
if {[string match $filter $event]} {
if {[info commands $coro] ne ""} {
$coro $argument
}
set found 1
break
}
}
}
# If no suspended coroutine, enqueue the event.
if {!$found} {
dict set feeds $fid pending [concat\
[dict get $feeds $fid pending] [list $argument]]
}
break
}
}
}
# =============================== wibble core =================================
# Advance to the next zone handler using the specified state list.
proc ::wibble::nexthandler {args} {
return -code 5 $args
}
# Send a response to the client.
proc ::wibble::sendresponse {response} {
return -code 6 $response
}
# Register a zone handler.
proc ::wibble::handle {prefix command args} {
variable zonehandlers
lappend zonehandlers $prefix $command $args
}
# Schedule scripts to run on coroutine cleanup.
proc ::wibble::cleanup {args} {
upvar #2 cleanup cleanup
set cleanup [concat $args $cleanup]
}
# Get an HTTP request from a client.
proc ::wibble::getrequest {port chan peerhost peerport} {
# The HTTP header uses CR/LF line breaks.
chan configure $chan -translation crlf
# Receive and parse the first line. Process "." and ".." path components.
regexp {^\s*(\S*)\s+(\S*)\s+(.*?)\s*$} [getline] _ method uri protocol
regexp {^([^?]*)(\?.*)?$} $uri _ path query
set path [regsub -all {(?:/|^)\.(?=/|$)} [encoding convertfrom utf-8 [dehex $path]] /]
while {[regexp -indices {(?:/[^/]*/+|^[^/]*/+|^)\.\.(?=/|$)} $path range]} {
set path [string replace $path {*}$range ""]
}
set path [regsub -all {//+} /$path /]
# Start building the request structure.
set request [dict create socket $chan peerhost $peerhost peerport $peerport\
port $port rawtime [clock seconds] time [clock format [clock seconds]]\
method $method uri $uri path $path protocol $protocol rawheader {}]
# Parse the query string.
if {$query ne ""} {
dict set request rawquery $query
dict set request query [dequery [string range $query 1 end]]
}
# Receive and parse the headers.
while {[set line [getline]] ne ""} {
dict lappend request rawheader $line
}
dict set request header [deheader [join [dict get $request rawheader] \n]]
# Process qvalues in accept* headers.
foreach {header key} {accept type accept-charset charset
accept-encoding encoding accept-language language} {
set preferences {}
if {[dict exists $request header $header]} {
set options {}
foreach {option params} [dict get $request header $header] {
if {![dict exists $params q]
|| ![string is double -strict [dict get $params q]]} {
lappend options [list $option 1]
} elseif {[dict get $params q] > 0} {
lappend options [list $option [dict get $params q]]
}
}
foreach elem [lsort -index 1 -decreasing -real $options] {
lappend preferences [lindex $elem 0]
}
}
dict set request accept $key $preferences
}
# Get and parse the request body, if there is one.
if {$method eq "POST"} {
# Get the request body.
if {[dict exists $request header transfer-encoding]
&& [dict get $request header transfer-encoding] eq "chunked"} {
# Receive chunked request body.
set data ""
while {[scan [getline] %x length] == 1 && $length > 0} {
chan configure $chan -translation binary
append data [getblock $length]
chan configure $chan -translation crlf
}
} else {
# Receive non-chunked request body.
chan configure $chan -translation binary
set data [getblock [dict get $request header content-length]]
chan configure $chan -translation crlf
}
# Parse the request body.
dict set request rawpost $data
set post ""
switch [if {[dict exists $request header content-type ""]} {
dict get $request header content-type ""
}] {
multipart/form-data {
# Interpret multipart/form-data (required for file uploads).
set data \r\n$data
set sep \r\n--[dict get $request header content-type boundary]
set beg [expr {[string first $sep $data] + 2}]
set end [expr {[string first $sep $data $beg] - 1}]
while {$beg < $end} {
set beg [expr {[string first \n $data $beg] + 1}]
set part [string range $data $beg $end]
set split [string first \r\n\r\n $part]
set val [deheader [string map {\r ""}\
[string range $part 0 [expr {$split - 1}]]]]
dict set val "" [string range $part [expr {$split + 4}] end]
if {[dict exists $val content-disposition name]} {
lappend post [dict get $val content-disposition name] $val
} else {
lappend post "" $val
}
set beg [expr {$end + 3}]
set end [expr {[string first $sep $data $beg] - 1}]
}
} text/plain {
# Interpret text/plain POSTs.
foreach elem [lrange [split $data \n] 0 end-1] {
regexp {([^\r=]*)(?:(=[^\r]*))?} $elem _ key val
if {$val ne ""} {
set val [list "" [string range $val 1 end]]
}
lappend post $key $val
}
} text/xml {
# Interpret text/xml POSTs.
dict set post xml "" [deurl $data]
} application/x-www-form-urlencoded - default {
# Interpret URL-encoded POSTs (the default).
set post [dequery $data]
}}
dict set request post $post
}
return $request
}
# Get a response from the zone handlers.
proc ::wibble::getresponse {request} {
variable zonehandlers
set system [list [dict create options {} request $request]]
# Process all zone handlers.
foreach {prefix command options} $zonehandlers {
set match $prefix
if {[string index $match end] ne "/"} {
append match /
}
# Run the zone handler on all states with requests in the zone.
set i 0
foreach {state} $system {
set path [dict get $state request path]
if {$path eq $prefix
|| [string equal -length [string length $match] $match $path]} {
set suffix [string range $path [string length $prefix] end]
# Replace the options in the state dict.
dict set state options $options
dict set state options prefix $prefix
dict set state options suffix $suffix
if {[dict exists $options root]} {
dict set state options fspath\
[dict get $options root]/$suffix
}
# Invoke the handler and process its outcome.
try {
{*}$command $state
} on 5 outcome {
# [nexthandler]: Update the system and continue processing.
set system [lreplace $system $i $i {*}$outcome]
} on 6 outcome {
# [sendresponse]: A response has been obtained. Return it.
return $outcome
}
}
incr i
}
}
# Return 501 as default response.
dict create status 501 header {content-type text/plain}\
content "not implemented: [dict get $request uri]\n"
}
# Main connection processing loop.
proc ::wibble::process {port socket peerhost peerport} {
set cleanup {
{chan close $file}
{chan close $socket}
{dict unset ::wibble::icc::feeds $coro}
}
try {
set coro [info coroutine]
icc configure $coro accept readable copydone timeout
chan configure $socket -blocking 0
while {1} {
# Get request from client, then formulate a response to the reqeust.
set request [getrequest $port $socket $peerhost $peerport]
set response [getresponse $request]
# Get the content channel and/or size.
set size 0
if {[dict exists $response contentfile]} {
set size [file size [dict get $response contentfile]]
if {[dict get $request method] ne "HEAD"} {
set file [open [dict get $response contentfile]]
}
} elseif {[dict exists $response header content-encoding] &&
[dict get $response header content-encoding] eq "gzip"
} {
set gzip [binary format "H*iH*" "1f8b0800" [clock seconds] "0003"]
set content [dict get $response content]
append gzip [zlib deflate $content]
append gzip [binary format i [zlib crc32 $content]]
append gzip [binary format i [string length $content]]
set response [dict merge $response {
header {
Vary Accept-Encoding
Content-Encoding gzip
Accept-Ranges bytes
}
}]
dict set response content $gzip
set size [string length [dict get $response content]]
} elseif {[dict exists $response contentchan]} {
if {[dict exists $response contentsize]} {
set size [dict get $response contentsize]
}
set file [dict get $response contentchan]
} elseif {[dict exists $response content]} {
if {[dict exists $response charset]} {
set charset [dict get $response charset]
} else {
set charset iso8859-1
}
dict set response content [encoding convertto $charset \
[dict get $response content]]
set size [string length [dict get $response content]]
}
# Try to parse the Range request header if present.
set begin 0
set end [expr {$size - 1}]
if {[dict exists $request header range]
&& [regexp {^bytes=(\d*)-(\d*)$} [dict get $request header range]\
_ begin end]
&& [dict get $response status] == 200} {
dict set response status 206
if {$begin eq "" || $begin >= $size} {
set begin 0
}
if {$end eq "" || $end >= $size || $end < $begin} {
set end [expr {$size - 1}]
}
}
# Add content-length and content-range response headers.
dict set response header content-length [expr {$end - $begin + 1}]
if {[dict get $response status] == 206} {
dict set response header content-range "bytes $begin-$end/$size"
}
# Send the response header to the client.
chan puts $socket "HTTP/1.1 [dict get $response status]"
foreach {key val} [dict get $response header] {
set normalizedkey [lsearch -exact -sorted -inline -nocase {
Accept-Ranges Age Allow Cache-Control Connection
Content-Disposition Content-Encoding Content-Language
Content-Length Content-Location Content-MD5 Content-Range
Content-Type Date ETag Expires Last-Modified Location Pragma
Proxy-Authenticate Retry-After Server Set-Cookie Trailer
Transfer-Encoding Upgrade Vary Via Warning WWW-Authenticate
Access-Control-Allow-Origin Access-Control-Allow-Credentials
Access-Control-Expose-Headers Access-Control-Max-Age
Access-Control-Allow-Methods Access-Control-Allow-Headers
} $key]
if {$normalizedkey ne ""} {
set key $normalizedkey
}
foreach line [split $val \n] {
chan puts $socket "$key: $line"
}
}
chan puts $socket ""
# If requested, send the response content to the client.
if {[dict get $request method] ne "HEAD"} {
chan configure $socket -translation binary
if {[info exists file]} {
# Asynchronously send response content from a channel.
chan configure $file -translation binary
chan seek $file $begin
chan copy $file $socket -size [expr {$end - $begin + 1}]\
-command [list ::wibble::icc put $coro copydone]
if {[llength [set data [icc get $coro copydone]]] == 3} {
error [lindex $data 2]
}
} elseif {[dict exists $response content]} {
# Send buffered response content.
chan puts -nonewline $socket [string range\
[dict get $response content] $begin $end]
}
}
# Close the content file or channel.
if {[info exists file]} {
chan close $file
unset file
}
# Flush the outgoing buffer.
if {[dict exists $request header connection] && [dict get $request header connection] eq "close"} {
chan close $socket
break
} else {
chan flush $socket
}
unset request
}
} on error {"" options} {
# Log errors and report them to the client, if possible.
variable errorcount
incr errorcount
set message "*** INTERNAL SERVER ERROR (BEGIN #$errorcount) ***"
if {[info exists request]} {
foreach {key val} [dumprequest $request] {
append message "\n$key: $val"
}
} else {
append message "\nsocket: $socket"
append message "\npeerhost: $peerhost"
append message "\npeerport: $peerport"
append message "\nrawtime: [clock seconds]"
append message "\ntime: [clock format [clock seconds]]"
}
append message "\nerrorinfo: [dict get $options -errorinfo]"
append message "\n*** INTERNAL SERVER ERROR (END #$errorcount) ***"
log $message
catch {
set message [encoding convertto iso8859-1 $message]
chan configure $socket -translation crlf
chan puts $socket "HTTP/1.1 500 Internal Server Error"
chan puts $socket "Content-Type: text/plain"
chan puts $socket "Content-Length: [string length $message]"
chan puts $socket "Connection: close"
chan puts $socket ""
chan configure $socket -translation binary
chan puts $socket $message
}
} finally {
# Always run scheduled cleanup scripts on coroutine termination.
foreach script $cleanup {
catch $script
}
}
}
# Listen for incoming connections.
proc ::wibble::listen {port} {
socket -server [list apply {{port socket peerhost peerport} {
coroutine $socket ::wibble::process $port $socket $peerhost $peerport
} ::wibble} $port] $port
}
# Log an error. Feel free to replace this procedure as needed.
proc ::wibble::log {message} {
chan puts stderr $message
}
# vim: set sts=4 sw=4 tw=80 et ft=tcl: