2 coded by Ketmar // Invisible Vector (psyc://ketmar.no-ip.org/~Ketmar)
3 Understanding is not required. Only obedience.
5 This program is free software. It comes without any warranty, to
6 the extent permitted by applicable law. You can redistribute it
7 and/or modify it under the terms of the Do What The Fuck You Want
8 To Public License, Version 2, as published by Sam Hocevar. See
9 http://sam.zoy.org/wtfpl/COPYING for more details.
11 Requires [ socket httpreq ]
19 | obuf code msg ftype postData req ctype |
40 aEmit value: 'HTTP/1.0 '.
41 aEmit value: (code printWidth: 3).
43 aEmit value: msg asString.
45 aEmit value: 'Expires: Thu, 01 Dec 1994 16:00:00 GMT\r\n'.
46 aEmit value: 'Cache-Control: no-cache, no-store, must-revalidate\r\n'.
47 aEmit value: 'Connection: close\r\n'.
48 aEmit value: 'Content-Type: '.
50 aEmit value: 'text/html\r\n'.
51 aEmit value: 'Content-Length: '.
52 aEmit value: (obuf size asString).
53 aEmit value: '\r\n\r\n'.
58 ctype := 'text/plain'.
60 self emit: '<html><body>nothing to see here</body></html>'.
71 sendFile: fl emit: aEmit [
74 [ 'sending ' print. left print. ' bytes...' printNl ] runLocked.
75 aEmit value: 'HTTP/1.0 '.
76 aEmit value: (code printWidth: 3).
78 aEmit value: msg asString.
80 aEmit value: 'Connection: close\r\n'.
81 aEmit value: 'Content-Type: '.
84 aEmit value: 'Content-Length: '.
85 aEmit value: (left asString).
86 aEmit value: '\r\n\r\n'.
87 buf := String new: 4096.
88 [ left > 0 ] whileTrue: [
89 fl read: buf size: (rd := left min: (buf size)).
91 rd < buf size ifTrue: [ aEmit value: (buf from: 1 to: rd) ] ifFalse: [ aEmit value: buf ].
97 process: aReq emit: aEmit [
100 ctype := 'text/html'.
101 (fl := self openFile)
103 self sendFile: fl emit: aEmit
105 obuf := StringBuffer new.
114 class: HttpDispatcher
118 pd := Dictionary new.
121 ^addHandler: aPath handler: aHandler [
122 pd ifNil: [ self initialize ].
123 pd at: aPath put: aHandler
126 ^findHandler: aPath [
128 pd ifNil: [ self initialize ].
129 h := pd at: aPath ifAbsent: [ HttpHandler ].
135 class: HttpShedulerProcList [
136 | procs curProc count |
141 self in: obj var: #count put: 0.
150 curProc ifNil: [ ^nil ].
156 procs := Link value: aProc next: procs.
157 curProc ifNil: [ curProc := procs ].
165 [ link isNil ] whileFalse: [
166 link value == aProc ifTrue: [ ^true ].
176 [ link isNil ] whileFalse: [
177 link value == aProc ifTrue: [
178 prev ifNil: [ procs := procs next ] ifNotNil: [ prev next: link next ].
179 curProc ifNotNil: [ curProc value == aProc ifTrue: [ curProc := nil ] ].
192 (prc := curProc) ifNil: [ prc := procs ] ifNotNil: [ prc := prc next ].
193 [ prc ] whileNotNil: [
194 prc value isWaiting ifFalse: [ ^(curProc := prc) value ].
197 "start to current (inclusive)"
200 [ prc value isWaiting ifFalse: [ ^(curProc := prc) value ].
201 flg := prc == curProc.
203 flg ] whileFalse: [ ].
211 [ link isNil ] whileFalse: [
212 aBlock value: link value.
223 Process subclass: HttpProcess [
224 | worker socket inbuf outbuf waiting hdr pdleft pdata |
229 "worker := HttpWorker new."
230 self in: obj var: #socket put: sk.
231 self in: obj var: #waiting put: true.
232 (args := Array new: 1) at: 1 put: obj.
234 ctx setup: (obj findMethod: #run) withArguments: args.
256 outbuf ifNil: [ ^false ].
263 "'doWrite:' printNl. outbuf asString printNl."
265 socket canWrite ifTrue: [
266 s := outbuf asString.
268 sent := socket send: s.
269 "'sent: ' print. sent printNl."
270 sent < 0 ifTrue: [ sent := s size ].
275 "'NO MORE!' printNl."
278 ] ifNotNil: [ outbuf clear ].
279 ] ifFalse: [ outbuf clear; addLast: s ].
281 (socket selectFor: 2 timeout: -1) < 0 ifTrue: [ socket close. outbuf := nil ].
291 [ hdrDone ] whileFalse: [
292 "[ 'rcv; id=' print. self id printNl. ] runLocked."
293 (s := socket recv: 2048) ifNil: [ ^false ]. "error"
294 "[ 'GOT; id=' print. self id print. '; s=' print. s printNl. ] runLocked."
296 hdr := hdr + s. s := nil.
297 "[ 'got: ' printNl. s printNl. ] runLocked."
298 p := hdr position: '\r\n\r\n'.
299 "[ '***p=' print. p printNl. ] runLocked."
301 inbuf := StringBuffer new.
302 inbuf << (hdr from: p+1).
303 hdr := hdr from: 1 to: p-1.
304 "[ 'headers:' printNl. hdr print. ] runLocked."
305 req := HTTPRequest new: hdr abortBlock: [:err |
306 outbuf := StringBuffer new.
308 'HTTP/1.0 500 Internal Error\r\n' <<
309 'Connection: close\r\n' <<
310 'Content-type: text/plain\r\n' <<
312 'internal error\n\n' <<
317 [ 'path: ' print. req path printNl ] runLocked.
318 req method = 'POST' ifTrue: [
319 (pdleft := req field: 'content-length') ifNotNil: [
320 (pdleft := pdleft asNumber) ifNotNil: [
321 [ 'post data size: ' print. pdleft printNl. ] runLocked.
322 pdleft < 65536 ifTrue: [
323 pdata := StringBuffer new.
324 [ pdleft > 0 ] whileTrue: [
325 [ waiting := true ] runLocked. System yield: true.
326 (s := socket recv: (pdleft min: 2048)) ifNil: [ ^false ]. "error"
327 "[ 's: ' print. s printNl. ] runLocked."
328 s isEmpty ifFalse: [ pdata << s. pdleft := pdleft - s size ].
331 [ 'got ' print. pdata size print. ' post data bytes' printNl. ] runLocked.
333 pdata := pdata asString fromUrl.
334 [ 'pd: ' print. pdata printNl ] runLocked.
336 req parseVars: pdata asString.
342 "[ req debugDump ] runLocked."
343 p := HttpDispatcher findHandler: (req path).
344 outbuf := StringBuffer new.
347 'HTTP/1.0 404 Not Found\r\n' <<
348 'Connection: close\r\n' <<
349 'Content-type: text/plain\r\n' <<
351 'void runner!' ] runLocked.
354 p process: req emit: [:txt | [ outbuf << txt ] runLocked ].
356 hdr size > 32768 ifTrue: [ ^false ]. "headers too big"
359 [ waiting := true ] runLocked. System yield: true.
364 class: HttpSheduler [
365 | procs abort slice lsk tokill |
370 self in: obj var: #procs put: (HttpShedulerProcList new).
371 self in: obj var: #abort put: false.
372 self in: obj var: #tokill put: (List new).
386 aTicks < 0 ifTrue: [ slice := 1 ] ifFalse: [ slice := aTicks + 1 ]
391 proc := HttpProcess new: sock.
402 wa := Array new: (procs size) + 1.
403 wa at: 1 put: lsk socket.
406 prc isWaiting ifTrue: [ wa at: idx put: prc socket socket ].
414 wa := Array new: (procs size).
417 prc wantWrite ifTrue: [ wa at: idx put: prc socket socket ].
425 prc wantWrite ifTrue: [ prc doWrite ].
427 prc wantWrite ifFalse: [ tokill add: prc ].
430 "'running: ' print. prc id print."
432 res := prc doExecute: slice.
433 "'; res=' print. res printNl."
435 case: 4 do: [ "process complete"
436 "' WW: ' print. prc wantWrite printNl."
438 ifTrue: [ prc waiting: false ]
439 ifFalse: [ tokill add: prc ].
441 case: 5 do: [ prc waiting: false ]; "time quantum expired"
442 case: 7 do: [ ]; "yielded; do nothing, prc takes care about it's 'waiting' state"
443 else: [ tokill add: prc. prc errorReport: res ].
446 runSR: anArray sidx: idx [
449 aa := anArray at: idx.
451 aa ifTrue: [ self runOne: prc ].
456 tokill do: [:prc | prc socket close. procs remove: prc ].
461 procs ifNil: [ 'no processes' printNl ].
463 (procs current == prc ifTrue: [ '*' ] ifFalse: [ ' ' ]) print.
464 'process id=' print. prc id print.
465 '; waiting=' print. prc isWaiting print.
466 '; wantWrite=' print. prc wantWrite print.
472 | tout sres csock ra wa |
473 [ abort ] whileFalse: [
477 'no active processes...' printNl.
478 sres := lsk selectFor: 1 timeout: -1.
479 sres <= 0 ifTrue: [ ^false ].
480 'client comes!' printNl.
482 self newProcess: csock.
484 procs sheduleNext ifNotNil: [
485 "has something to do"
493 "'building read array...' printNl."
494 ra := self buildReadArray.
495 "'building write array...' printNl."
496 wa := self buildWriteArray.
497 "'tout: ' print. tout print. '; ra=' print. ra print. '; wa=' print. wa printNl."
498 sres := Socket selectRead: ra write: wa timeout: tout.
499 "' res: ' print. sres print. '; ra=' print. ra print. '; wa=' print. wa printNl."
503 "'trying RA...' printNl."
504 self runSR: ra sidx: 2.
505 "'trying WA...' printNl."
506 self runSR: wa sidx: 1.
507 "'removing zombies...' printNl."
509 "'checking for the new client...' printNl."
511 'client comes!' printNl.
513 self newProcess: csock.
516 "'procs current = ' print. procs current printNl."
517 procs current ifNil: [
519 "'new procs current = ' print. procs current printNl."
521 procs current ifNotNil: [ self runOne: procs current. self killUndead. ].
527 "create a default socket on which to listen"
530 [ cnt > 0 ] whileTrue: [
531 lsk := TCPSocket new.
532 (lsk bind: '127.0.0.1' port: aPort) < 0 ifFalse: [
533 'HTTP server is ready at port ' print. aPort printNl.
534 lsk listen < 0 ifTrue: [ lsk close. self error: 'can''t listen'. ].
540 'binding failed.' printNl.
544 self error: 'can''t start sheduler: binding error'.
551 HttpDispatcher addHandler: '/' handler: (HttpHandlerMain new).
552 HttpDispatcher addHandler: '/js/' handler: (HttpHandlerJS new).
553 (HttpSheduler new) startOn: 6789.