aboutsummaryrefslogtreecommitdiff
path: root/bin/pddp/pddpserver.tcl
blob: 4b96be2a3a51a55721857faa4eba24d42a5c1b5e (plain)
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
# pddpserver.tcl

# Synopsis
#   not to be run by itself (see pddpboot.tcl)

# based on:

# Simple Sample httpd/1.[01] server
# Stephen Uhler (c) 1996-1997 Sun Microsystems

# http://cvs.sourceforge.net/viewcvs.py/tclhttpd/tclhttpd/bin/mini/mini1.1.tcl

# modified by krzYszcz (2005):
#   putting per-server data and all commands in a namespace "::pddp"
#   supporting sourcing from within Pd, through the "pddpboot.tcl" wrapper
#   inserting the .pd handler
#   lots of other changes, too many to list here (run "diff" if curious...)

if {![namespace exists ::pddp]} {
    puts stderr "Error: invalid invocation of pddpserver (boot pddp first)"
    puts stderr "exiting..."
    exit 1
}

if {$::pddp::testrun} {  ;# true if sourced from standalone "pddpboot.tcl"
    puts stderr "Loading pddpserver, test run..."
    proc bgerror {msg} {
	global errorInfo
	puts stderr "bgerror: $msg\n$errorInfo"
    }
} else {
    puts stderr "Loading pddpserver"
    catch {console show}
}

namespace eval ::pddp {
    variable thePort 0
    variable theState
    variable theMimeTypes
    variable theErrors
    variable theErrorFormat

    # "theState" contains the server state:
    #  root:      the root of the document directory
    #  default:   default document name
    #  listen:    the main listening socket id
    #  naccepts:  a count of accepted connections so far
    #  maxtime:   the max time (msec) allowed to complete an http request
    #  maxused:   the max # of requests for a socket
    array set theState {
	root       ""
	default    index.html
	listen     ""
	naccepts   0
	nrequests  0
	nerrors    0
	maxtime	   600000
	maxused	   25
	bufsize	   32768
    }

    set theState(root)  $env(HOME)

    array set theMimeTypes {
	{}      text/plain
	.txt    text/plain
	.html   text/html
	.gif    image/gif
	.jpg    image/jpeg
	.pd     text/html
    }

    # HTTP/1.[01] error codes (the ones we use)
    array set theErrors {
	204 {No Content}
	400 {Bad Request}
	404 {Not Found}
	405 {Method Not Allowed}
	408 {Request Timeout}
	411 {Length Required}
	419 {Expectation Failed}
	500 {Internal Server Error}
	503 {Service Unavailable}
	504 {Service Temporarily Unavailable}
	505 {HTTP Version Not Supported}
    }

    # Generic error response
    set theErrorFormat {
	<title>Error: %1$s</title>
	Got the error: <b>%2$s</b><br>
	while trying to obtain <b>%3$s</b>
    }
}

proc ::pddp::srvUse {{root {}} {port 0}} {
    variable theState
    if {[string length $theState(listen)]} {
	if {[string length $root] && ![string equal $root $theState(root)]} {
	    srvLog $theState(listen) Warning "Redirection attempt for $root"
	}
    } else {
	srvStart $root $port
    }
}

# Start the server by listening for connections on the desired port.

proc ::pddp::srvStart {{root {}} {port 0}} {
    variable thePort
    variable theState

    puts stderr "Starting pddp server on [info hostname]"
    if {[string length $root]} {
	set theState(root) $root
    }
    # we do not handle multiple pddpservers, LATER rethink
    srvStop
    array set theState [list naccepts 0 nrequests 0 nerrors 0]

    for { set thePort $port } {$thePort < 65535 } {incr thePort } {
	if {[catch {set theState(listen) \
			[socket -server ::pddp::srvAccept $thePort]} res]} {
	    if {$thePort == 0} {
		# FIXME this is a critical error
		set thePort 32768
	    }
        } else { break }
    }
    if {$thePort == 65535} {
	srvLog none Error "Could not find port available for listening"
    } else {
	if {$thePort == 0} {
	    set thePort [lindex [fconfigure $theState(listen) -sockname] 2]
	}
	srvLog $theState(listen) Port $thePort
	srvLog $theState(listen) Root directory \"$root\"
    }
    after 120 update  ;# FIXME might be needed on windows they say, test there
    return $thePort
}

proc ::pddp::srvStop {} {
    variable thePort
    variable theState
    if {[string length $theState(listen)]} {
	if {[catch {close $theState(listen)} res]} {
	    srvLog $theState(listen) Warning [list $res while closing socket]
	} else {
	    srvLog $theState(listen) Closed.
	}
	set theState(listen) ""
	update
    }
}

# Accept a new connection from the server and set up a handler
# to read the request from the client.

proc ::pddp::srvAccept {sock ipaddr port} {
    variable theState
    variable theSockData$sock
    # reject remote requests, LATER revisit
    if {[string equal $ipaddr "127.0.0.1"]} {
	incr theState(naccepts)
	srvReset $sock $theState(maxused)
	srvLog $sock Connect $ipaddr $port
    } else {
	srvLog $sock Warning "rejecting remote connection request from $ipaddr"
	srvSockDone $sock 1
    }
}

# Initialize or reset the socket state

proc ::pddp::srvReset {sock nlft} {
    variable theState
    upvar 0 ::pddp::theSockData$sock sockData
    array set sockData [list state start linemode 1 version 0 nleft $nlft]
    set sockData(cancel) \
	[after $theState(maxtime) [list srvTimeout $sock]]
    fconfigure $sock -blocking 0 -buffersize $theState(bufsize) \
	-translation {auto crlf}
    fileevent $sock readable [list ::pddp::srvRead $sock]
}

# Read data from a client request
# 1) read the request line
# 2) read the mime headers
# 3) read the additional data (if post && content-length not satisfied)

proc ::pddp::srvRead {sock} {
    variable theState
    upvar 0 ::pddp::theSockData$sock sockData

    # Use line mode to read the request and the mime headers

    if {$sockData(linemode)} {
	set readCount [gets $sock line]
	set state [string compare $readCount 0],$sockData(state)
	switch -glob -- $state {
	    1,start {
		if {[regexp {(HEAD|POST|GET) ([^?]+)\??([^ ]*) HTTP/1.([01])} \
			 $line x sockData(proto) sockData(url) \
			 sockData(query) sockData(version)]} {
		    set sockData(state) mime
		    incr theState(nrequests)
		    srvLog $sock Request $sockData(nleft) $line
		} else {
		    srvError $sock 400 $line
		}
	    }
	    0,start {
		srvLog $sock Warning "Initial blank line fetching request"
	    }
	    1,mime {
		if {[regexp {([^:]+):[ 	]*(.*)}  $line {} key value]} {
		    set key [string tolower $key]
		    set sockData(key) $key
		    if {[info exists sockData(mime,$key)]} {
			append sockData(mime,$key) ", $value"
		    } else {
			set sockData(mime,$key) $value
		    }
		} elseif {[regexp {^[ 	]+(.+)} $line {} value] && \
			      [info exists sockData(key)]} {
		    append sockData(mime,$sockData($key)) " " $value
		} else {
		    srvError $sock 400 $line
		}
	    }
	    0,mime {
	        if {$sockData(proto) == "POST" && \
	        	[info exists sockData(mime,content-length)]} {
		    set sockData(linemode) 0
	            set sockData(count) $sockData(mime,content-length)
	            if {$sockData(version) && \
			    [info exists sockData(mime,expect)]} {
			if {$sockData(mime,expect) == "100-continue"} {
			    puts $sock "100 Continue HTTP/1.1\n"
			    flush $sock
			} else {
			    srvError $sock 419 $sockData(mime,expect)
			}
		    }
		    fconfigure $sock -translation {binary crlf}
	        } elseif {$sockData(proto) != "POST"}  {
		    srvRespond $sock
	        } else {
		    srvError $sock 411 "Confusing mime headers"
	        }
	    }
	    -1,* {
	    	if {[eof $sock]} {
		    srvLog $sock Error "Broken connection fetching request"
		    srvSockDone $sock 1
	    	} else {
	    	    puts stderr "Partial read, retrying"
	    	}
	    }
	    default {
		srvError $sock 404 "Invalid http state: $state,[eof $sock]"
	    }
	}

    # Use counted mode to get the post data

    } elseif {![eof $sock]} {
        append sockData(postdata) [read $sock $sockData(count)]
        set sockData(count) [expr {$sockData(mime,content-length) - \
				       [string length $sockData(postdata)]}]
        if {$sockData(count) == 0} {
	    srvRespond $sock
	}
    } else {
	srvLog $sock Error "Broken connection reading POST data"
	srvSockDone $sock 1
    }
}

# Done with the socket, either close it, or set up for next fetch
#  sock:     The socket I'm done with
#  doclose:  If true, close the socket, otherwise set up for reuse

proc ::pddp::srvSockDone {sock doclose} {
    variable theState
    upvar 0 ::pddp::theSockData$sock sockData

    after cancel $sockData(cancel)
    set nleft [incr sockData(nleft) -1]
    unset sockData
    if {$doclose} {
	close $sock
    } else {
	srvReset $sock $nleft
    }
    return ""
}

# A timeout happened

proc ::pddp::srvTimeout {sock} {
    srvError $sock 408
}

# FIXME test if "path" has its patch window already open...
proc ::pddp::srvPdHandler {sock path} {
    set dir [file dirname $path]
    set tail [file tail $path]
    if {[catch {pd [concat pd open $tail $dir \;]}]} {
	srvError $sock 504
    } else {
	srvError $sock 204
	# FIXME raise; focus (test on windows)
    }
}

# Handle file system queries.  This is a place holder for a more
# generic dispatch mechanism.

proc ::pddp::srvRespond {sock} {
    variable theState
    variable theUrlCache
    upvar 0 ::pddp::theSockData$sock sockData

    regsub {(^http://[^/]+)?} $sockData(url) {} url
    if {[info exists theUrlCache($url)]} {
    	set mypath $theUrlCache($url)
    } else {
	set mypath [srvUrl2File $theState(root) $url]
	if {[file isdirectory $mypath]} {
	    append mypath / $theState(default)
	}
	set theUrlCache($url) $mypath
    }
    if {[string length $mypath] == 0} {
	srvError $sock 400
    } elseif {![file readable $mypath]} {
	if {[string equal [file tail $mypath] "favicon.ico"]} {
	    srvError $sock 204  ;# FIXME design something
	} else {
	    srvError $sock 404 $mypath
	}
    } else {
	set ext [file extension $mypath]

	if {[string equal $ext ".pd"]} {
	    srvPdHandler $sock $mypath
	    return
	}

	puts $sock "HTTP/1.$sockData(version) 200 Data follows"
	puts $sock "Date: [srvGetDate [clock seconds]]"
	puts $sock "Last-Modified: [srvGetDate [file mtime $mypath]]"
	puts $sock "Content-Type: [srvContentType $ext]"
	puts $sock "Content-Length: [file size $mypath]"

	## Should also close socket if recvd connection close header
	set doclose [expr {$sockData(nleft) == 0}]

	if {$doclose} {
	    puts $sock "Connection close:"
	} elseif {$sockData(version) == 0 && \
		      [info exists sockData(mime,connection)]} {
	    if {$sockData(mime,connection) == "Keep-Alive"} {
	        set doclose 0
	        puts $sock "Connection: Keep-Alive"
	    }
	}
	puts $sock ""
	flush $sock

	if {$sockData(proto) != "HEAD"} {
	    set in [open $mypath]
	    fconfigure $sock -translation binary
	    fconfigure $in -translation binary
	    fcopy $in $sock -command \
		[list ::pddp::srvCopyDone $in $sock $doclose]
	} else {
	    srvSockDone $sock $doclose
	}
    }
}

# Callback when file is done being output to client
#  in:       The fd for the file being copied
#  sock:     The client socket
#  doclose:  close the socket if true
#  bytes:    The # of bytes copied
#  error:    The error message (if any)

proc ::pddp::srvCopyDone {in sock doclose bytes {error {}}} {
    close $in
    srvLog $sock Done $bytes bytes
    srvSockDone $sock $doclose
}

# Convert the file suffix into a mime type.

proc ::pddp::srvContentType {ext} {
    variable theMimeTypes
    set type text/plain
    catch {set type $theMimeTypes($ext)}
    return $type
}

# Respond with an error reply
# sock:  The socket handle to the client
# code:  The httpd error code
# args:  Additional information for error logging

proc ::pddp::srvError {sock code args} {
    variable theState
    variable theErrors
    variable theErrorFormat
    upvar 0 ::pddp::theSockData$sock sockData

    append sockData(url) ""
    incr theState(nerrors)
    set message [format $theErrorFormat $code $theErrors($code) $sockData(url)]
    append head "HTTP/1.$sockData(version) $code $theErrors($code)"  \n
    append head "Date: [srvGetDate [clock seconds]]"  \n
    append head "Connection: close"  \n
    append head "Content-Length: [string length $message]"  \n

    # Because there is an error condition, the socket may be "dead"

    catch {
	fconfigure $sock  -translation crlf
	puts -nonewline $sock $head\n$message
	flush $sock
    } reason
    srvSockDone $sock 1
    if {$code < 300} {set status Status} else {set status Error}
    srvLog $sock $status $code $theErrors($code) $args $reason
}

# Generate a date string in HTTP format.

proc ::pddp::srvGetDate {seconds} {
    return [clock format $seconds -format {%a, %d %b %Y %T %Z}]
}

# Log an Httpd transaction.
# This should be replaced as needed.

proc ::pddp::srvLog {sock args} {
    puts stderr "pddp log ($sock): $args"
}

# Convert a url into a pathname. (UNIX version only)
# This is probably not right, and belongs somewhere else.
# - Remove leading http://... if any
# - Collapse all /./ and /../ constructs
# - expand %xx sequences -> disallow "/"'s  and "."'s due to expansions

proc ::pddp::srvUrl2File {root url} {
    regsub -all {//+} $url / url		;# collapse multiple /'s
    while {[regsub -all {/\./} $url / url]} {}	;# collapse /./
    while {[regsub -all {/\.\.(/|$)} $url /\x81\\1 url]} {} ;# mark /../
    while {[regsub "/\[^/\x81]+/\x81/" $url / url]} {} ;# collapse /../
    if {![regexp "\x81|%2\[eEfF]" $url]} {	;# invalid /../, / or . ?
	return $root[srvCgiMap $url]
    } else {
	return ""
    }
}

# Decode url-encoded strings.

proc ::pddp::srvCgiMap {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]
}

if {$::pddp::testrun} {  ;# true if tested as a standalone script
    if {$argc > 1} {
	set root [lindex $argv 1]
	set port [lindex $argv 2]
	if {![string is integer -strict $port]} {
	    set port 32768
	}
    } else {
	set root $env(HOME)
	set port 32768
    }
    ::pddp::srvStart $root $port
    vwait forever
}