From 421dc8c7141ecb6297996f7370d96e7e99894683 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@robocracy.org>
Date: Fri, 24 Jun 2011 17:21:45 -0400
Subject: arc3.1.tar

---
 srv.arc | 573 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 573 insertions(+)
 create mode 100644 srv.arc

(limited to 'srv.arc')

diff --git a/srv.arc b/srv.arc
new file mode 100644
index 0000000..65db716
--- /dev/null
+++ b/srv.arc
@@ -0,0 +1,573 @@
+; 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.
+
-- 
cgit v1.2.3