574 lines
16 KiB
Plaintext
574 lines
16 KiB
Plaintext
; HTTP Server.
|
|
|
|
; 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.
|
|
|