PageRenderTime 13ms CodeModel.GetById 2ms app.highlight 6ms RepoModel.GetById 1ms app.codeStats 0ms

/srv.arc

http://github.com/alimoeeny/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