Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

couple tests for srv

  • Loading branch information...
commit c2ea1102fdae3fa0d24af6de43467aaaa43a0359 1 parent 11ab421
@awwx awwx authored
Showing with 598 additions and 0 deletions.
  1. +575 −0 srv.arc
  2. +23 −0 srv.t
View
575 srv.arc
@@ -0,0 +1,575 @@
+; HTTP Server.
+
+(use io html)
+
+; To improve performance with static files, set static-max-age*.
+
+(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
+
+(= quitsrv* nil breaksrv* nil)
+
+(def serve ((o port 8080))
+ (wipe quitsrv*)
+ (ensure-srvdirs)
+ (map [apply new-bgthread _] pending-bgthreads*)
+ (w/socket s port
+ (setuid 2) ; XXX switch from root to pg
+ (prn "ready to serve port " port)
+ (flushout)
+ (= currsock* s)
+ (until quitsrv*
+ (handle-request s breaksrv*)))
+ (prn "quit server"))
+
+(def serve1 ((o port 8080))
+ (w/socket s port (handle-request s t)))
+
+(def ensure-srvdirs ()
+ (map ensure-dir (list arcdir* logdir* staticdir*)))
+
+(= srv-noisy* nil)
+
+; http requests currently capped at 2 meg by socket-accept
+
+; should threads process requests one at a time? no, then
+; a browser that's slow consuming the data could hang the
+; whole server.
+
+; wait for a connection from a browser and start a thread
+; to handle it. also arrange to kill that thread if it
+; has not completed in threadlife* seconds.
+
+(= threadlife* 30 requests* 0 requests/ip* (table)
+ throttle-ips* (table) ignore-ips* (table) spurned* (table))
+
+(def handle-request (s breaksrv)
+ (if breaksrv
+ (handle-request-1 s)
+ (errsafe (handle-request-1 s))))
+
+(def handle-request-1 (s)
+ (let (i o ip) (socket-accept s)
+ (if (and (or (ignore-ips* ip) (abusive-ip ip))
+ (++ (spurned* ip 0)))
+ (force-close i o)
+ (do (++ requests*)
+ (++ (requests/ip* ip 0))
+ (with (th1 nil th2 nil)
+ (= th1 (thread
+ (after (handle-request-thread i o ip)
+ (close i o)
+ (kill-thread th2))))
+ (= th2 (thread
+ (sleep threadlife*)
+ (unless (dead th1)
+ (prn "srv thread took too long for " ip))
+ (break-thread th1)
+ (force-close i o))))))))
+
+; Returns true if ip has made req-limit* requests in less than
+; req-window* seconds. If an ip is throttled, only 1 request is
+; allowed per req-window* seconds. If an ip makes req-limit*
+; requests in less than dos-window* seconds, it is a treated as a DoS
+; attack and put in ignore-ips* (for this server invocation).
+
+; To adjust this while running, adjust the req-window* time, not
+; req-limit*, because algorithm doesn't enforce decreases in the latter.
+
+(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
+
+(def abusive-ip (ip)
+ (and (only.> (requests/ip* ip) 250)
+ (let now (seconds)
+ (do1 (if (req-times* ip)
+ (and (>= (qlen (req-times* ip))
+ (if (throttle-ips* ip) 1 req-limit*))
+ (let dt (- now (deq (req-times* ip)))
+ (if (< dt dos-window*) (set (ignore-ips* ip)))
+ (< dt req-window*)))
+ (do (= (req-times* ip) (queue))
+ nil))
+ (enq now (req-times* ip))))))
+
+(def handle-request-thread (i o ip)
+ (with (nls 0 lines nil line nil responded nil t0 (msec))
+ (after
+ (whilet c (unless responded (readc i))
+ (if srv-noisy* (pr c))
+ (if (is c #\newline)
+ (if (is (++ nls) 2)
+ (let (type op args n cooks) (parseheader (rev lines))
+ (let t1 (msec)
+ (case type
+ get (respond o op args cooks ip)
+ post (handle-post i o op args n cooks ip)
+ (respond-err o "Unknown request: " (car lines)))
+ (log-request type op args cooks ip t0 t1)
+ (set responded)))
+ (do (push (string (rev line)) lines)
+ (wipe line)))
+ (unless (is c #\return)
+ (push c line)
+ (= nls 0))))
+ (close i o)))
+ (harvest-fnids))
+
+(def log-request (type op args cooks ip t0 t1)
+ (with (parsetime (- t1 t0) respondtime (- (msec) t1))
+ (srvlog 'srv ip
+ parsetime
+ respondtime
+ (if (> (+ parsetime respondtime) 1000) "***" "")
+ type
+ op
+ (let arg1 (car args)
+ (if (caris arg1 "fnid") "" arg1))
+ cooks)))
+
+; Could ignore return chars (which come from textarea fields) here by
+; (unless (is c #\return) (push c line))
+
+(def handle-post (i o op args n cooks ip)
+ (if srv-noisy* (pr "Post Contents: "))
+ (if (no n)
+ (respond-err o "Post request without Content-Length.")
+ (let line nil
+ (whilet c (and (> n 0) (readc i))
+ (if srv-noisy* (pr c))
+ (-- n)
+ (push c line))
+ (if srv-noisy* (pr "\n\n"))
+ (respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
+
+(= header* "HTTP/1.1 200 OK
+Content-Type: text/html; charset=utf-8
+Connection: close")
+
+(= type-header* (table))
+
+(def gen-type-header (ctype)
+ (+ "HTTP/1.0 200 OK
+Content-Type: "
+ ctype
+ "
+Connection: close"))
+
+(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
+ '((gif "image/gif")
+ (jpg "image/jpeg")
+ (png "image/png")
+ (text/html "text/html; charset=utf-8")))
+
+(= rdheader* "HTTP/1.0 302 Moved")
+
+(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
+
+(def save-optime (name elapsed)
+ ; this is the place to put a/b testing
+ ; toggle a flag and push elapsed into one of two lists
+ (++ (opcounts* name 0))
+ (unless (optimes* name) (= (optimes* name) (queue)))
+ (enq-limit elapsed (optimes* name) 1000))
+
+; For ops that want to add their own headers. They must thus remember
+; to prn a blank line before anything meant to be part of the page.
+
+(mac defop-raw (name parms . body)
+ (w/uniq t1
+ `(= (srvops* ',name)
+ (fn ,parms
+ (let ,t1 (msec)
+ (do1 (do ,@body)
+ (save-optime ',name (- (msec) ,t1))))))))
+
+(mac defopr-raw (name parms . body)
+ `(= (redirector* ',name) t
+ (srvops* ',name) (fn ,parms ,@body)))
+
+(mac defop (name parm . body)
+ (w/uniq gs
+ `(do (wipe (redirector* ',name))
+ (defop-raw ,name (,gs ,parm)
+ (w/stdout ,gs (prn) ,@body)))))
+
+; Defines op as a redirector. Its retval is new location.
+
+(mac defopr (name parm . body)
+ (w/uniq gs
+ `(do (set (redirector* ',name))
+ (defop-raw ,name (,gs ,parm)
+ ,@body))))
+
+;(mac testop (name . args) `((srvops* ',name) ,@args))
+
+(deftem request
+ args nil
+ cooks nil
+ ip nil)
+
+(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
+
+(def respond (str op args cooks ip)
+ (w/stdout str
+ (iflet f (srvops* op)
+ (let req (inst 'request 'args args 'cooks cooks 'ip ip)
+ (if (redirector* op)
+ (do (prn rdheader*)
+ (prn "Location: " (f str req))
+ (prn))
+ (do (prn header*)
+ (awhen (max-age* op)
+ (prn "Cache-Control: max-age=" it))
+ (f str req))))
+ (let filetype (static-filetype op)
+ (aif (and filetype (file-exists (string staticdir* op)))
+ (do (prn (type-header* filetype))
+ (awhen static-max-age*
+ (prn "Cache-Control: max-age=" it))
+ (prn)
+ (w/infile i it
+ (whilet b (readb i)
+ (writeb b str))))
+ (respond-err str unknown-msg*))))))
+
+(def static-filetype (sym)
+ (let fname (coerce sym 'string)
+ (and (~find #\/ fname)
+ (case (downcase (last (check (tokens fname #\.) ~single)))
+ "gif" 'gif
+ "jpg" 'jpg
+ "jpeg" 'jpg
+ "png" 'png
+ "css" 'text/html
+ "txt" 'text/html
+ "htm" 'text/html
+ "html" 'text/html
+ "arc" 'text/html
+ ))))
+
+(def respond-err (str msg . args)
+ (w/stdout str
+ (prn header*)
+ (prn)
+ (apply pr msg args)))
+
+(def parseheader (lines)
+ (let (type op args) (parseurl (car lines))
+ (list type
+ op
+ args
+ (and (is type 'post)
+ (some (fn (s)
+ (and (begins s "Content-Length:")
+ (errsafe:coerce (cadr (tokens s)) 'int)))
+ (cdr lines)))
+ (some (fn (s)
+ (and (begins s "Cookie:")
+ (parsecookies s)))
+ (cdr lines)))))
+
+; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
+
+(def parseurl (s)
+ (let (type url) (tokens s)
+ (let (base args) (tokens url #\?)
+ (list (sym (downcase type))
+ (sym (cut base 1))
+ (if args
+ (parseargs args)
+ nil)))))
+
+; I don't urldecode field names or anything in cookies; correct?
+
+(def parseargs (s)
+ (map (fn ((k v)) (list k (urldecode v)))
+ (map [tokens _ #\=] (tokens s #\&))))
+
+(def parsecookies (s)
+ (map [tokens _ #\=]
+ (cdr (tokens s [or (whitec _) (is _ #\;)]))))
+
+(def arg (req key) (alref req!args key))
+
+; *** Warning: does not currently urlencode args, so if need to do
+; that replace v with (urlencode v).
+
+(def reassemble-args (req)
+ (aif req!args
+ (apply string "?" (intersperse '&
+ (map (fn ((k v))
+ (string k '= v))
+ it)))
+ ""))
+
+(= fns* (table) fnids* nil timed-fnids* nil)
+
+; count on huge (expt 64 10) size of fnid space to avoid clashes
+
+(def new-fnid ()
+ (check (sym (rand-string 10)) ~fns* (new-fnid)))
+
+(def fnid (f)
+ (atlet key (new-fnid)
+ (= (fns* key) f)
+ (push key fnids*)
+ key))
+
+(def timed-fnid (lasts f)
+ (atlet key (new-fnid)
+ (= (fns* key) f)
+ (push (list key (seconds) lasts) timed-fnids*)
+ key))
+
+; Within f, it will be bound to the fn's own fnid. Remember that this is
+; so low-level that need to generate the newline to separate from the headers
+; within the body of f.
+
+(mac afnid (f)
+ `(atlet it (new-fnid)
+ (= (fns* it) ,f)
+ (push it fnids*)
+ it))
+
+;(defop test-afnid req
+; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
+; (pr "click here")))
+
+; To be more sophisticated, instead of killing fnids, could first
+; replace them with fns that tell the server it's harvesting too
+; aggressively if they start to get called. But the right thing to
+; do is estimate what the max no of fnids can be and set the harvest
+; limit there-- beyond that the only solution is to buy more memory.
+
+(def harvest-fnids ((o n 50000)) ; was 20000
+ (when (len> fns* n)
+ (pull (fn ((id created lasts))
+ (when (> (since created) lasts)
+ (wipe (fns* id))
+ t))
+ timed-fnids*)
+ (atlet nharvest (trunc (/ n 10))
+ (let (kill keep) (split (rev fnids*) nharvest)
+ (= fnids* (rev keep))
+ (each id kill
+ (wipe (fns* id)))))))
+
+(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
+
+(= dead-msg* "\nUnknown or expired link.")
+
+(defop-raw x (str req)
+ (w/stdout str
+ (aif (fns* (sym (arg req "fnid")))
+ (it req)
+ (pr dead-msg*))))
+
+(defopr-raw y (str req)
+ (aif (fns* (sym (arg req "fnid")))
+ (w/stdout str (it req))
+ "deadlink"))
+
+; For asynchronous calls; discards the page. Would be better to tell
+; the fn not to generate it.
+
+(defop-raw a (str req)
+ (aif (fns* (sym (arg req "fnid")))
+ (tostring (it req))))
+
+(defopr r req
+ (aif (fns* (sym (arg req "fnid")))
+ (it req)
+ "deadlink"))
+
+(defop deadlink req
+ (pr dead-msg*))
+
+(def url-for (fnid)
+ (string fnurl* "?fnid=" fnid))
+
+(def flink (f)
+ (string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
+
+(def rflink (f)
+ (string rfnurl* "?fnid=" (fnid f)))
+
+; Since it's just an expr, gensym a parm for (ignored) args.
+
+(mac w/link (expr . body)
+ `(tag (a href (flink (fn (,(uniq)) ,expr)))
+ ,@body))
+
+(mac w/rlink (expr . body)
+ `(tag (a href (rflink (fn (,(uniq)) ,expr)))
+ ,@body))
+
+(mac onlink (text . body)
+ `(w/link (do ,@body) (pr ,text)))
+
+(mac onrlink (text . body)
+ `(w/rlink (do ,@body) (pr ,text)))
+
+; bad to have both flink and linkf; rename flink something like fnid-link
+
+(mac linkf (text parms . body)
+ `(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
+
+(mac rlinkf (text parms . body)
+ `(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
+
+;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
+
+;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
+
+(mac w/link-if (test expr . body)
+ `(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
+ ,@body))
+
+(def fnid-field (id)
+ (gentag input type 'hidden name 'fnid value id))
+
+; f should be a fn of one arg, which will be http request args.
+
+(def fnform (f bodyfn (o redir))
+ (tag (form method 'post action (if redir rfnurl2* fnurl*))
+ (fnid-field (fnid f))
+ (bodyfn)))
+
+; Could also make a version that uses just an expr, and var capture.
+; Is there a way to ensure user doesn't use "fnid" as a key?
+
+(mac aform (f . body)
+ (w/uniq ga
+ `(tag (form method 'post action fnurl*)
+ (fnid-field (fnid (fn (,ga)
+ (prn)
+ (,f ,ga))))
+ ,@body)))
+
+;(defop test1 req
+; (fnform (fn (req) (prn) (pr req))
+; (fn () (single-input "" 'foo 20 "submit"))))
+
+;(defop test2 req
+; (aform (fn (req) (pr req))
+; (single-input "" 'foo 20 "submit")))
+
+; Like aform except creates a fnid that will last for lasts seconds
+; (unless the server is restarted).
+
+(mac taform (lasts f . body)
+ (w/uniq (gl gf gi ga)
+ `(withs (,gl ,lasts
+ ,gf (fn (,ga) (prn) (,f ,ga)))
+ (tag (form method 'post action fnurl*)
+ (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+ ,@body))))
+
+(mac arform (f . body)
+ `(tag (form method 'post action rfnurl*)
+ (fnid-field (fnid ,f))
+ ,@body))
+
+; overlong
+
+(mac tarform (lasts f . body)
+ (w/uniq (gl gf)
+ `(withs (,gl ,lasts ,gf ,f)
+ (tag (form method 'post action rfnurl*)
+ (fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
+ ,@body))))
+
+(mac aformh (f . body)
+ `(tag (form method 'post action fnurl*)
+ (fnid-field (fnid ,f))
+ ,@body))
+
+(mac arformh (f . body)
+ `(tag (form method 'post action rfnurl2*)
+ (fnid-field (fnid ,f))
+ ,@body))
+
+; only unique per server invocation
+
+(= unique-ids* (table))
+
+(def unique-id ((o len 8))
+ (let id (sym (rand-string (max 5 len)))
+ (if (unique-ids* id)
+ (unique-id)
+ (= (unique-ids* id) id))))
+
+(def srvlog (type . args)
+ (w/appendfile o (logfile-name type)
+ (w/stdout o (atomic (apply prs (seconds) args) (prn)))))
+
+(def logfile-name (type)
+ (string logdir* type "-" (memodate)))
+
+(with (lastasked nil lastval nil)
+
+(def memodate ()
+ (let now (seconds)
+ (if (or (no lastasked) (> (- now lastasked) 60))
+ (= lastasked now lastval (datestring))
+ lastval)))
+
+)
+
+(defop || req (pr "It's alive."))
+
+(defop topips req
+ (when (admin (get-user req))
+ (whitepage
+ (sptab
+ (each ip (let leaders nil
+ (maptable (fn (ip n)
+ (when (> n 100)
+ (insort (compare > requests/ip*)
+ ip
+ leaders)))
+ requests/ip*)
+ leaders)
+ (let n (requests/ip* ip)
+ (row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
+
+(defop spurned req
+ (when (admin (get-user req))
+ (whitepage
+ (sptab
+ (map (fn ((ip n)) (row ip n))
+ (sortable spurned*))))))
+
+; eventually promote to general util
+
+(def sortable (ht (o f >))
+ (let res nil
+ (maptable (fn kv
+ (insort (compare f cadr) kv res))
+ ht)
+ res))
+
+
+; Background Threads
+
+(= bgthreads* (table) pending-bgthreads* nil)
+
+(def new-bgthread (id f sec)
+ (aif (bgthreads* id) (break-thread it))
+ (= (bgthreads* id) (new-thread (fn ()
+ (while t
+ (sleep sec)
+ (f))))))
+
+; should be a macro for this?
+
+(mac defbg (id sec . body)
+ `(do (pull [caris _ ',id] pending-bgthreads*)
+ (push (list ',id (fn () ,@body) ,sec)
+ pending-bgthreads*)))
+
+
+
+; Idea: make form fields that know their value type because of
+; gensymed names, and so the receiving fn gets args that are not
+; strings but parsed values.
+
View
23 srv.t
@@ -0,0 +1,23 @@
+(use runtime test test-by-example cwd)
+
+(w/testdir
+ (w/cwd testdir
+
+ (let r (runtime '(srv))
+
+ (example-test r #<<.
+> (sortable (obj a 99 b 3 c 25))
+((a 99) (c 25) (b 3))
+.
+ )
+
+ ;; maybe use a custodian to shutdown everything when the test is
+ ;; finished?
+
+ (r!eval '(thread:serve))
+
+ ;; todo
+ (sleep 1)
+
+ (testis (tostring (system "curl -s -S http://localhost:8080/"))
+ "It's alive."))))
Please sign in to comment.
Something went wrong with that request. Please try again.