http/httpsvx.st

   1 "
   2  coded by Ketmar // Vampire Avalon (psyc://ketmar.no-ip.org/~Ketmar)
   3  Understanding is not required. Only obedience.
   4
   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.
  10 "
  11 Requires [ socket httpreq ]
  12
  13 Package [
  14   HttpServer
  15 ]
  16
  17
  18 class: HttpHandler [
  19   | obuf code msg ftype postData req ctype |
  20
  21   postData: pd [
  22     postData := pd
  23   ]
  24
  25   emit: aStr [
  26     obuf << aStr
  27   ]
  28
  29   set2xx [
  30     code := 200.
  31     msg := 'OK'.
  32   ]
  33
  34   set4xx [
  35     code := 404.
  36     msg := 'Not Found'.
  37   ]
  38
  39   emitAll: aEmit [
  40     aEmit value: 'HTTP/1.0 '.
  41     aEmit value: (code printWidth: 3).
  42     aEmit value: ' '.
  43     aEmit value: msg asString.
  44     aEmit value: '\r\n'.
  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: '.
  49     aEmit value: ctype.
  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'.
  54     aEmit value: obuf.
  55   ]
  56
  57   emitBody [
  58     ctype := 'text/plain'.
  59     self set4xx.
  60     self emit: '<html><body>nothing to see here</body></html>'.
  61   ]
  62
  63   fileType: ft [
  64     ftype := ft
  65   ]
  66
  67   openFile [
  68     ^nil
  69   ]
  70
  71   sendFile: fl emit: aEmit [
  72     | buf left rd |
  73     left := fl size.
  74     [ 'sending ' print. left print. ' bytes...' printNl ] runLocked.
  75     aEmit value: 'HTTP/1.0 '.
  76     aEmit value: (code printWidth: 3).
  77     aEmit value: ' '.
  78     aEmit value: msg asString.
  79     aEmit value: '\r\n'.
  80     aEmit value: 'Connection: close\r\n'.
  81     aEmit value: 'Content-Type: '.
  82     aEmit value: ftype.
  83     aEmit value: '\r\n'.
  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)).
  90       "FIXME: any errors?"
  91       rd < buf size ifTrue: [ aEmit value: (buf from: 1 to: rd) ] ifFalse: [ aEmit value: buf ].
  92       left := left - rd.
  93     ].
  94     fl close.
  95   ]
  96
  97   process: aReq emit: aEmit [
  98     | fl |
  99     req := aReq.
 100     ctype := 'text/html'.
 101     (fl := self openFile)
 102       ifNotNil: [
 103         self sendFile: fl emit: aEmit
 104       ] ifNil: [
 105         obuf := StringBuffer new.
 106         self set4xx;
 107           emitBody;
 108           emitAll: aEmit.
 109       ]
 110   ]
 111 ]
 112
 113
 114 class: HttpDispatcher
 115 | pd |
 116 [
 117   ^initialize [
 118     pd := Dictionary new.
 119   ]
 120
 121   ^addHandler: aPath handler: aHandler [
 122     pd ifNil: [ self initialize ].
 123     pd at: aPath put: aHandler
 124   ]
 125
 126   ^findHandler: aPath [
 127     | h |
 128     pd ifNil: [ self initialize ].
 129     h := pd at: aPath ifAbsent: [ HttpHandler ].
 130     ^h new.
 131   ]
 132 ]
 133
 134
 135 class: HttpShedulerProcList [
 136   | procs curProc count |
 137
 138   ^new [
 139     | obj |
 140     obj := super new.
 141     self in: obj var: #count put: 0.
 142     ^obj
 143   ]
 144
 145   isEmpty [
 146     ^procs isNil
 147   ]
 148
 149   current [
 150     curProc ifNil: [ ^nil ].
 151     ^curProc value
 152   ]
 153
 154   add: aProc [
 155     aProc ifNotNil: [
 156       procs := Link value: aProc next: procs.
 157       curProc ifNil: [ curProc := procs ].
 158       count := count + 1.
 159     ].
 160   ]
 161
 162   includes: aProc [
 163     | link |
 164     link := procs.
 165     [ link isNil ] whileFalse: [
 166       link value == aProc ifTrue: [ ^true ].
 167       link := link next
 168     ].
 169     ^false
 170   ]
 171
 172   remove: aProc [
 173     | link prev |
 174     link := procs.
 175     prev := nil.
 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 ] ].
 180         count := count - 1.
 181         ^true
 182       ].
 183       prev := link.
 184       link := link next
 185     ].
 186     ^false
 187   ]
 188
 189   sheduleNext [
 190     | prc flg |
 191     "next to end"
 192     (prc := curProc) ifNil: [ prc := procs ] ifNotNil: [ prc := prc next ].
 193     [ prc ] whileNotNil: [
 194       prc value isWaiting ifFalse: [ ^(curProc := prc) value ].
 195       prc := prc next.
 196     ].
 197     "start to current (inclusive)"
 198     curProc ifNotNil: [
 199       prc := procs.
 200       [ prc value isWaiting ifFalse: [ ^(curProc := prc) value ].
 201         flg := prc == curProc.
 202         prc := prc next.
 203         flg ] whileFalse: [ ].
 204     ].
 205     ^curProc := nil.
 206   ]
 207
 208   do: aBlock [
 209     | link |
 210     link := procs.
 211     [ link isNil ] whileFalse: [
 212       aBlock value: link value.
 213       link := link next
 214     ]
 215   ]
 216
 217   size [
 218     ^count
 219   ]
 220 ]
 221
 222
 223 Process subclass: HttpProcess [
 224   | worker socket inbuf outbuf waiting hdr pdleft pdata |
 225
 226   ^new: sk [
 227     | obj ctx args |
 228     obj := super new.
 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.
 233     ctx := Context new.
 234     ctx setup: (obj findMethod: #run) withArguments: args.
 235     obj context: ctx.
 236     ^obj
 237   ]
 238
 239   id [
 240     ^socket fd
 241   ]
 242
 243   socket [
 244     ^socket
 245   ]
 246
 247   isWaiting [
 248     ^waiting
 249   ]
 250
 251   waiting: aFlag [
 252     waiting := aFlag
 253   ]
 254
 255   wantWrite [
 256     outbuf ifNil: [ ^false ].
 257     ^true
 258   ]
 259
 260   doWrite [
 261     | sent s |
 262     [
 263       "'doWrite:' printNl. outbuf asString printNl."
 264       outbuf ifNotNil: [
 265         socket canWrite ifTrue: [
 266           s := outbuf asString.
 267           s isEmpty ifFalse: [
 268             sent := socket send: s.
 269             "'sent: ' print. sent printNl."
 270             sent < 0 ifTrue: [ sent := s size ].
 271             s := s from: sent+1.
 272           ].
 273           s isEmpty ifTrue: [
 274             context ifNil: [
 275               "'NO MORE!' printNl."
 276               outbuf := nil.
 277               socket close.
 278             ] ifNotNil: [ outbuf clear ].
 279           ] ifFalse: [ outbuf clear; addLast: s ].
 280         ] ifFalse: [
 281           (socket selectFor: 2 timeout: -1) < 0 ifTrue: [ socket close. outbuf := nil ].
 282         ]
 283       ]
 284     ] runLocked.
 285   ]
 286
 287   run [
 288     | s hdrDone p req |
 289     hdr := ''.
 290     hdrDone := false.
 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."
 295       s isEmpty ifFalse: [
 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."
 300         p ifNotNil: [
 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.
 307             [ outbuf <<
 308                 'HTTP/1.0 500 Internal Error\r\n' <<
 309                 'Connection: close\r\n' <<
 310                 'Content-type: text/plain\r\n' <<
 311                 '\r\n' <<
 312                 'internal error\n\n' <<
 313                 err ] runLocked.
 314             ^false
 315           ].
 316           hdr := nil.
 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 ].
 329                     s := nil.
 330                   ].
 331                   [ 'got ' print. pdata size print. ' post data bytes' printNl. ] runLocked.
 332                   "
 333                   pdata := pdata asString fromUrl.
 334                   [ 'pd: ' print. pdata printNl ] runLocked.
 335                   "
 336                   req parseVars: pdata asString.
 337                   pdata := nil.
 338                 ]
 339               ]
 340             ]
 341           ].
 342           "[ req debugDump ] runLocked."
 343           p := HttpDispatcher findHandler: (req path).
 344           outbuf := StringBuffer new.
 345           p ifNil: [
 346             [ outbuf <<
 347               'HTTP/1.0 404 Not Found\r\n' <<
 348               'Connection: close\r\n' <<
 349               'Content-type: text/plain\r\n' <<
 350               '\r\n' <<
 351               'void runner!' ] runLocked.
 352             ^true
 353           ].
 354           p process: req emit: [:txt | [ outbuf << txt ] runLocked ].
 355         ] ifNil: [
 356           hdr size > 32768 ifTrue: [ ^false ].  "headers too big"
 357         ].
 358       ].
 359       [ waiting := true ] runLocked. System yield: true.
 360     ].
 361   ]
 362 ]
 363
 364 class: HttpSheduler [
 365   | procs abort slice lsk tokill |
 366
 367   ^new: aSlice [
 368     | obj |
 369     obj := super new.
 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).
 373     obj slice: aSlice.
 374     ^obj
 375   ]
 376
 377   ^new [
 378     ^self new: 10000
 379   ]
 380
 381   slice [
 382     ^slice
 383   ]
 384
 385   slice: aTicks [
 386     aTicks < 0 ifTrue: [ slice := 1 ] ifFalse: [ slice := aTicks + 1 ]
 387   ]
 388
 389   newProcess: sock [
 390     | proc |
 391     proc := HttpProcess new: sock.
 392     procs add: proc.
 393     ^true
 394   ]
 395
 396   abortAll [
 397     abort := true
 398   ]
 399
 400   buildReadArray [
 401     | wa idx |
 402     wa := Array new: (procs size) + 1.
 403     wa at: 1 put: lsk socket.
 404     idx := 2.
 405     procs do: [:prc |
 406       prc isWaiting ifTrue: [ wa at: idx put: prc socket socket ].
 407       idx := idx + 1.
 408     ].
 409     ^wa
 410   ]
 411
 412   buildWriteArray [
 413     | wa idx |
 414     wa := Array new: (procs size).
 415     idx := 1.
 416     procs do: [:prc |
 417       prc wantWrite ifTrue: [ wa at: idx put: prc socket socket ].
 418       idx := idx + 1.
 419     ].
 420     ^wa
 421   ]
 422
 423   runOne: prc [
 424     | res |
 425     prc wantWrite ifTrue: [ prc doWrite ].
 426     prc context ifNil: [
 427       prc wantWrite ifFalse: [ tokill add: prc ].
 428       ^self
 429     ].
 430     "'running: ' print. prc id print."
 431     prc waiting: false.
 432     res := prc doExecute: slice.
 433     "'; res=' print. res printNl."
 434     Case test: res;
 435       case: 4 do: [  "process complete"
 436         "'  WW: ' print. prc wantWrite printNl."
 437         prc wantWrite
 438           ifTrue: [ prc waiting: false ]
 439           ifFalse: [ tokill add: prc ].
 440       ];
 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 ].
 444   ]
 445
 446   runSR: anArray sidx: idx [
 447     | aa |
 448     procs do: [:prc |
 449       aa := anArray at: idx.
 450       idx := idx + 1.
 451       aa ifTrue: [ self runOne: prc ].
 452     ].
 453   ]
 454
 455   killUndead [
 456     tokill do: [:prc | prc socket close. procs remove: prc ].
 457     tokill := List new.
 458   ]
 459
 460   procDump [
 461     procs ifNil: [ 'no processes' printNl ].
 462     procs do: [:prc |
 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.
 467       '' printNl.
 468     ]
 469   ]
 470
 471   run [
 472     | tout sres csock ra wa |
 473     [ abort ] whileFalse: [
 474       procs isEmpty
 475         ifTrue: [
 476           "wait for client"
 477           'no active processes...' printNl.
 478           sres := lsk selectFor: 1 timeout: -1.
 479           sres <= 0 ifTrue: [ ^false ].
 480           'client comes!' printNl.
 481           csock := lsk accept.
 482           self newProcess: csock.
 483         ] ifFalse: [
 484           procs sheduleNext ifNotNil: [
 485             "has something to do"
 486             tout := 0.
 487           ] ifNil: [
 488             "nothing to do"
 489             tout := -1.
 490           ].
 491           "self procDump."
 492           tokill := List new.
 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."
 500           sres
 501             ifTrue: [
 502               "have something"
 503               "'trying RA...' printNl."
 504               self runSR: ra sidx: 2.
 505               "'trying WA...' printNl."
 506               self runSR: wa sidx: 1.
 507               "'removing zombies...' printNl."
 508               self killUndead.
 509               "'checking for the new client...' printNl."
 510               (ra at: 1) ifTrue: [
 511                 'client comes!' printNl.
 512                 csock := lsk accept.
 513                 self newProcess: csock.
 514               ].
 515             ].
 516           "'procs current = ' print. procs current printNl."
 517           procs current ifNil: [
 518             procs sheduleNext.
 519             "'new procs current = ' print. procs current printNl."
 520           ].
 521           procs current ifNotNil: [ self runOne: procs current. self killUndead. ].
 522         ].
 523     ].
 524   ]
 525
 526   startOn: aPort [
 527     "create a default socket on which to listen"
 528     | cnt |
 529     cnt := 20.
 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'. ].
 535         self run.
 536         lsk close.
 537         ^true
 538       ].
 539       lsk close.
 540       'binding failed.' printNl.
 541       cnt := cnt - 1.
 542       System sleep: 6.
 543     ].
 544     self error: 'can''t start sheduler: binding error'.
 545   ]
 546 ]
 547
 548
 549 "
 550 {
 551   HttpDispatcher addHandler: '/' handler: (HttpHandlerMain new).
 552   HttpDispatcher addHandler: '/js/' handler: (HttpHandlerJS new).
 553   (HttpSheduler new) startOn: 6789.
 554 }
 555 "