/srv.arc
Unknown | 613 lines | 492 code | 121 blank | 0 comment | 0 complexity | 0f6c860e7e85d780dcda7269976a7388 MD5 | raw file
1; HTTP Server. 2 3; To improve performance with static files, set static-max-age*. 4 5(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/") 6 7(= quitsrv* nil breaksrv* nil) 8 9(def serve ((o port 8080)) 10 (wipe quitsrv*) 11 (ensure-srvdirs) 12 (map [apply new-bgthread _] pending-bgthreads*) 13 (w/socket s port 14 (setuid 2) ; XXX switch from root to pg 15 (prn "ready to serve port " port) 16 (flushout) 17 (= currsock* s) 18 (until quitsrv* 19 (handle-request s breaksrv*))) 20 (prn "quit server")) 21 22(def serve1 ((o port 8080)) 23 (w/socket s port (handle-request s t))) 24 25(def ensure-srvdirs () 26 (map ensure-dir (list arcdir* logdir* staticdir*))) 27 28(= srv-noisy* nil) 29 30; http requests currently capped at 2 meg by socket-accept 31 32; should threads process requests one at a time? no, then 33; a browser that's slow consuming the data could hang the 34; whole server. 35 36; wait for a connection from a browser and start a thread 37; to handle it. also arrange to kill that thread if it 38; has not completed in threadlife* seconds. 39 40(= threadlife* 30 requests* 0 requests/ip* (table) 41 throttle-ips* (table) ignore-ips* (table) spurned* (table)) 42 43(def handle-request (s breaksrv) 44 (if breaksrv 45 (handle-request-1 s) 46 (errsafe (handle-request-1 s)))) 47 48(def handle-request-1 (s) 49 (with ((i o ip) (socket-accept s) 50 th1 nil th2 nil) 51 (++ requests*) 52 (let ip-wrapper (fn args 53 (if args 54 (= ip car.args) 55 ip)) 56 (= th1 (thread 57 (after (handle-request-thread i o ip-wrapper) 58 (close i o) 59 (kill-thread th2)))) 60 (= th2 (thread 61 (sleep threadlife*) 62 (unless (dead th1) 63 (prn "srv thread took too long for " ip)) 64 (kill-thread th1) 65 (force-close i o)))))) 66 67; Returns true if ip has made req-limit* requests in less than 68; req-window* seconds. If an ip is throttled, only 1 request is 69; allowed per req-window* seconds. If an ip makes req-limit* 70; requests in less than dos-window* seconds, it is a treated as a DoS 71; attack and put in ignore-ips* (for this server invocation). 72 73; To adjust this while running, adjust the req-window* time, not 74; req-limit*, because algorithm doesn't enforce decreases in the latter. 75 76(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2) 77 78(wipe show-abuse*) 79(def abusive-ip (ip) 80 (++ (requests/ip* ip 0)) 81 (if show-abuse* 82 (if (ignore-ips* ip) 83 (prn ip " ignored") 84 (prn ip " " (if (abusive-ip-core ip) "" "not ") "abusive (" requests/ip*.ip ")"))) 85 (and (or (ignore-ips* ip) (abusive-ip-core ip)) 86 (++ (spurned* ip 0)))) 87 88(def abusive-ip-core (ip) 89 (and (only.> (requests/ip* ip) 250) 90 (let now (seconds) 91 (do1 (if (req-times* ip) 92 (and (>= (qlen (req-times* ip)) 93 (if (throttle-ips* ip) 1 req-limit*)) 94 (let dt (- now (deq (req-times* ip))) 95 (if (< dt dos-window*) (set (ignore-ips* ip))) 96 (< dt req-window*))) 97 (do (= (req-times* ip) (queue)) 98 nil)) 99 (enq now (req-times* ip)))))) 100 101(let proxy-header "X-Forwarded-For: " 102 (def strip-header(s) 103 (subst "" proxy-header s)) 104 (def proxy-ip(ip-wrapper lines) 105 (aif (only.strip-header (car:keep [headmatch proxy-header _] lines)) 106 (ip-wrapper it) 107 (ip-wrapper)))) 108 109(wipe show-requests*) 110(def handle-request-thread (i o ip-wrapper) 111 (with (nls 0 lines nil line nil responded nil t0 (msec)) 112 (after 113 (whilet c (unless responded (readc i)) 114 (if srv-noisy* (pr c)) 115 (if (is c #\newline) 116 (if (is (++ nls) 2) 117 (let (type op args n cooks ctype) (parseheader (rev lines)) 118 (if show-requests* (prn lines)) 119 (unless (abusive-ip (proxy-ip ip-wrapper lines)) 120 (let t1 (msec) 121 (case type 122 get (respond o op args cooks 0 i "" (ip-wrapper)) 123 post (handle-post i o op args n cooks ctype (ip-wrapper)) 124 (respond-err o "Unknown request: " (car lines))) 125 (log-request type op args cooks (ip-wrapper) t0 t1))) 126 (set responded)) 127 (do (push (string (rev line)) lines) 128 (wipe line))) 129 (unless (is c #\return) 130 (push c line) 131 (= nls 0)))) 132 (close i o))) 133 (harvest-fnids)) 134 135(def log-request (type op args cooks ip t0 t1) 136 (with (parsetime (- t1 t0) respondtime (- (msec) t1)) 137 (srvlog 'srv ip 138 parsetime 139 respondtime 140 (if (> (+ parsetime respondtime) 1000) "***" "") 141 type 142 op 143 (let arg1 (car args) 144 (if (caris arg1 "fnid") "" arg1)) 145 cooks))) 146 147; Could ignore return chars (which come from textarea fields) here by 148; (unless (is c #\return) (push c line)) 149 150(def handle-post (i o op args n cooks ctype ip) 151 (if srv-noisy* (pr "Post Contents: ")) 152 (if (no n) 153 (respond-err o "Post request without Content-Length.") 154 (let line nil 155 (unless (begins ctype "multipart/form-data") 156 (whilet c (and (> n 0) (readc i)) 157 (if srv-noisy* (pr c)) 158 (-- n) 159 (push c line))) 160 (if srv-noisy* (pr "\n\n")) 161 (respond o op (+ (parseargs (string (rev line))) args) cooks n ctype i ip)))) 162 163(= header* "HTTP/1.1 200 OK 164Content-Type: text/html; charset=utf-8 165Connection: close") 166 167(= type-header* (table)) 168 169(def gen-type-header (ctype) 170 (+ "HTTP/1.0 200 OK 171Content-Type: " 172 ctype 173 " 174Connection: close")) 175 176(map (fn ((k v)) (= (type-header* k) (gen-type-header v))) 177 '((gif "image/gif") 178 (jpg "image/jpeg") 179 (png "image/png") 180 (text/html "text/html; charset=utf-8"))) 181 182(= rdheader* "HTTP/1.0 302 Moved") 183 184(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table)) 185 186(def save-optime (name elapsed) 187 ; this is the place to put a/b testing 188 ; toggle a flag and push elapsed into one of two lists 189 (++ (opcounts* name 0)) 190 (unless (optimes* name) (= (optimes* name) (queue))) 191 (enq-limit elapsed (optimes* name) 1000)) 192 193; For ops that want to add their own headers. They must thus remember 194; to prn a blank line before anything meant to be part of the page. 195 196(mac defop-raw (name parms . body) 197 (w/uniq t1 198 `(= (srvops* ',name) 199 (fn ,parms 200 (let ,t1 (msec) 201 (do1 (do ,@body) 202 (save-optime ',name (- (msec) ,t1)))))))) 203 204(mac defopr-raw (name parms . body) 205 `(= (redirector* ',name) t 206 (srvops* ',name) (fn ,parms ,@body))) 207 208(mac defop (name parm . body) 209 (w/uniq gs 210 `(do (wipe (redirector* ',name)) 211 (defop-raw ,name (,gs ,parm) 212 (w/stdout ,gs (prn) ,@body))))) 213 214; Defines op as a redirector. Its retval is new location. 215 216(mac defopr (name parm . body) 217 (w/uniq gs 218 `(do (set (redirector* ',name)) 219 (defop-raw ,name (,gs ,parm) 220 ,@body)))) 221 222;(mac testop (name . args) `((srvops* ',name) ,@args)) 223 224(deftem request 225 args nil 226 cooks nil 227 ctype nil 228 clen 0 229 in nil 230 ip nil) 231 232(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil) 233 234(def respond (str op args cooks clen ctype in ip) 235 (w/stdout str 236 (iflet f (srvops* op) 237 (let req (inst 'request 'args args 'cooks cooks 'ctype ctype 'clen clen 'in in 'ip ip) 238 (if (redirector* op) 239 (do (prn rdheader*) 240 (prn "Location: " (f str req)) 241 (prn)) 242 (do (prn header*) 243 (awhen (max-age* op) 244 (prn "Cache-Control: max-age=" it)) 245 (f str req)))) 246 (let filetype (static-filetype op) 247 (aif (and filetype (file-exists (string staticdir* op))) 248 (do (prn (type-header* filetype)) 249 (awhen static-max-age* 250 (prn "Cache-Control: max-age=" it)) 251 (prn) 252 (w/infile i it 253 (whilet b (readb i) 254 (writeb b str)))) 255 (respond-err str unknown-msg*)))))) 256 257(def static-filetype (sym) 258 (let fname (coerce sym 'string) 259 (and (~find #\/ fname) 260 (case (downcase (last (check (tokens fname #\.) ~single))) 261 "gif" 'gif 262 "jpg" 'jpg 263 "jpeg" 'jpg 264 "png" 'png 265 "css" 'text/html 266 "txt" 'text/html 267 "htm" 'text/html 268 "html" 'text/html 269 "arc" 'text/html 270 )))) 271 272(def respond-err (str msg . args) 273 (w/stdout str 274 (prn header*) 275 (prn) 276 (apply pr msg args))) 277 278(def parseheader (lines) 279 (let (type op args) (parseurl (car lines)) 280 (list type 281 op 282 args 283 (and (is type 'post) 284 (some (fn (s) 285 (and (begins s "Content-Length:") 286 (errsafe:coerce (cadr (tokens s)) 'int))) 287 (cdr lines))) 288 (some (fn (s) 289 (and (begins s "Cookie:") 290 (parsecookies s))) 291 (cdr lines)) 292 (and (is type 'post) 293 (some (fn (s) 294 (and (begins s "Content-Type: ") 295 (cut s (len "Content-Type: ")))) 296 (cdr lines)))))) 297 298; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug"))) 299 300(def parseurl (s) 301 (let (type url) (tokens s) 302 (let (base args) (tokens url #\?) 303 (list (sym (downcase type)) 304 (sym (cut base 1)) 305 (if args 306 (parseargs args) 307 nil))))) 308 309; I don't urldecode field names or anything in cookies; correct? 310 311(def parseargs (s) 312 (map (fn ((k v)) (list k (urldecode v))) 313 (map [tokens _ #\=] (tokens s #\&)))) 314 315(def parsecookies (s) 316 (map [tokens _ #\=] 317 (cdr (tokens s [or (whitec _) (is _ #\;)])))) 318 319(def arg (req key) (alref req!args key)) 320 321; *** Warning: does not currently urlencode args, so if need to do 322; that replace v with (urlencode v). 323 324(def reassemble-args (req) 325 (aif req!args 326 (apply string "?" (intersperse '& 327 (map (fn ((k v)) 328 (string k '= v)) 329 it))) 330 "")) 331 332(= fns* (table) fnids* nil timed-fnids* nil) 333 334; count on huge (expt 64 10) size of fnid space to avoid clashes 335 336(def new-fnid () 337 (check (sym (rand-string 10)) ~fns* (new-fnid))) 338 339(def fnid (f) 340 (atlet key (new-fnid) 341 (= (fns* key) f) 342 (push key fnids*) 343 key)) 344 345(def timed-fnid (lasts f) 346 (atlet key (new-fnid) 347 (= (fns* key) f) 348 (push (list key (seconds) lasts) timed-fnids*) 349 key)) 350 351; Within f, it will be bound to the fn's own fnid. Remember that this is 352; so low-level that need to generate the newline to separate from the headers 353; within the body of f. 354 355(mac afnid (f) 356 `(atlet it (new-fnid) 357 (= (fns* it) ,f) 358 (push it fnids*) 359 it)) 360 361;(defop test-afnid req 362; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it))))) 363; (pr "click here"))) 364 365; To be more sophisticated, instead of killing fnids, could first 366; replace them with fns that tell the server it's harvesting too 367; aggressively if they start to get called. But the right thing to 368; do is estimate what the max no of fnids can be and set the harvest 369; limit there-- beyond that the only solution is to buy more memory. 370 371(def harvest-fnids ((o n 50000)) ; was 20000 372 (when (len> fns* n) 373 (pull (fn ((id created lasts)) 374 (when (> (since created) lasts) 375 (wipe (fns* id)) 376 t)) 377 timed-fnids*) 378 (atlet nharvest (trunc (/ n 10)) 379 (let (kill keep) (split (rev fnids*) nharvest) 380 (= fnids* (rev keep)) 381 (each id kill 382 (wipe (fns* id))))))) 383 384(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a") 385 386(= dead-msg* "\nUnknown or expired link.") 387 388(defop-raw x (str req) 389 (w/stdout str 390 (aif (fns* (sym (arg req "fnid"))) 391 (it req) 392 (pr dead-msg*)))) 393 394(defopr-raw y (str req) 395 (aif (fns* (sym (arg req "fnid"))) 396 (w/stdout str (it req)) 397 "deadlink")) 398 399; For asynchronous calls; discards the page. Would be better to tell 400; the fn not to generate it. 401 402(defop-raw a (str req) 403 (aif (fns* (sym (arg req "fnid"))) 404 (tostring (it req)))) 405 406(defopr r req 407 (aif (fns* (sym (arg req "fnid"))) 408 (it req) 409 "deadlink")) 410 411(defop deadlink req 412 (pr dead-msg*)) 413 414(def url-for (fnid) 415 (string fnurl* "?fnid=" fnid)) 416 417(def flink (f) 418 (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req))))) 419 420(def rflink (f) 421 (string rfnurl* "?fnid=" (fnid f))) 422 423; Since it's just an expr, gensym a parm for (ignored) args. 424 425(mac w/link (expr . body) 426 `(tag (a href (flink (fn (,(uniq)) ,expr))) 427 ,@body)) 428 429(mac w/rlink (expr . body) 430 `(tag (a href (rflink (fn (,(uniq)) ,expr))) 431 ,@body)) 432 433(mac onlink (text . body) 434 `(w/link (do ,@body) (pr ,text))) 435 436(mac onrlink (text . body) 437 `(w/rlink (do ,@body) (pr ,text))) 438 439; bad to have both flink and linkf; rename flink something like fnid-link 440 441(mac linkf (text parms . body) 442 `(tag (a href (flink (fn ,parms ,@body))) (pr ,text))) 443 444(mac rlinkf (text parms . body) 445 `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text))) 446 447;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req)))) 448 449;(defop testf req (w/link (pr "ha ha ha") (pr "laugh"))) 450 451(mac w/link-if (test expr . body) 452 `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr))) 453 ,@body)) 454 455(def fnid-field (id) 456 (gentag input type 'hidden name 'fnid value id)) 457 458; f should be a fn of one arg, which will be http request args. 459 460(def fnform (f bodyfn (o redir)) 461 (tag (form method 'post action (if redir rfnurl2* fnurl*)) 462 (fnid-field (fnid f)) 463 (bodyfn))) 464 465; Could also make a version that uses just an expr, and var capture. 466; Is there a way to ensure user doesn't use "fnid" as a key? 467 468(mac aform (f . body) 469 (w/uniq ga 470 `(tag (form method 'post action fnurl*) 471 (fnid-field (fnid (fn (,ga) 472 (prn) 473 (,f ,ga)))) 474 ,@body))) 475 476(mac aform-multi (f . body) 477 (w/uniq ga 478 `(tag (form method 'post 479 enctype "multipart/form-data" 480 action (string fnurl* "?fnid=" 481 (fnid (fn (,ga) 482 (prn) 483 (,f ,ga))))) 484 ,@body))) 485 486;(defop test1 req 487; (fnform (fn (req) (prn) (pr req)) 488; (fn () (single-input "" 'foo 20 "submit")))) 489 490;(defop test2 req 491; (aform (fn (req) (pr req)) 492; (single-input "" 'foo 20 "submit"))) 493 494; Like aform except creates a fnid that will last for lasts seconds 495; (unless the server is restarted). 496 497(mac taform (lasts f . body) 498 (w/uniq (gl gf gi ga) 499 `(withs (,gl ,lasts 500 ,gf (fn (,ga) (prn) (,f ,ga))) 501 (tag (form method 'post action fnurl*) 502 (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf))) 503 ,@body)))) 504 505(mac arform (f . body) 506 `(tag (form method 'post action rfnurl*) 507 (fnid-field (fnid ,f)) 508 ,@body)) 509 510; overlong 511 512(mac tarform (lasts f . body) 513 (w/uniq (gl gf) 514 `(withs (,gl ,lasts ,gf ,f) 515 (tag (form method 'post action rfnurl*) 516 (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf))) 517 ,@body)))) 518 519(mac aformh (f . body) 520 `(tag (form method 'post action fnurl*) 521 (fnid-field (fnid ,f)) 522 ,@body)) 523 524(mac arformh (f . body) 525 `(tag (form method 'post action rfnurl2*) 526 (fnid-field (fnid ,f)) 527 ,@body)) 528 529; only unique per server invocation 530 531(= unique-ids* (table)) 532 533(def unique-id ((o len 8)) 534 (let id (sym (rand-string (max 5 len))) 535 (if (unique-ids* id) 536 (unique-id) 537 (= (unique-ids* id) id)))) 538 539(def srvlog (type . args) 540 (ontofile (logfile-name type) 541 (atomic (apply prs (seconds) args) (prn)))) 542 543(def logfile-name (type) 544 (string logdir* type "-" (memodate))) 545 546(with (lastasked nil lastval nil) 547 548(def memodate () 549 (let now (seconds) 550 (if (or (no lastasked) (> (- now lastasked) 60)) 551 (= lastasked now lastval (datestring)) 552 lastval))) 553 554) 555 556(defop || req (pr "It's alive.")) 557 558(defop topips req 559 (when (admin (get-user req)) 560 (whitepage 561 (sptab 562 (each ip (let leaders nil 563 (maptable (fn (ip n) 564 (when (> n 100) 565 (insort (compare > requests/ip*) 566 ip 567 leaders))) 568 requests/ip*) 569 leaders) 570 (let n (requests/ip* ip) 571 (row ip n (pr (num (* 100 (/ n requests*)) 1))))))))) 572 573(defop spurned req 574 (when (admin (get-user req)) 575 (whitepage 576 (sptab 577 (map (fn ((ip n)) (row ip n)) 578 (sortable spurned*)))))) 579 580; eventually promote to general util 581 582(def sortable (ht (o f >)) 583 (let res nil 584 (maptable (fn kv 585 (insort (compare f cadr) kv res)) 586 ht) 587 res)) 588 589 590; Background Threads 591 592(= bgthreads* (table) pending-bgthreads* nil) 593 594(def new-bgthread (id f sec) 595 (aif (bgthreads* id) (break-thread it)) 596 (= (bgthreads* id) (new-thread (fn () 597 (while t 598 (sleep sec) 599 (f)))))) 600 601; should be a macro for this? 602 603(mac defbg (id sec . body) 604 `(do (pull [caris _ ',id] pending-bgthreads*) 605 (push (list ',id (fn () ,@body) ,sec) 606 pending-bgthreads*))) 607 608 609 610; Idea: make form fields that know their value type because of 611; gensymed names, and so the receiving fn gets args that are not 612; strings but parsed values. 613