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