/app.arc

http://github.com/alimoeeny/arc · Unknown · 671 lines · 566 code · 105 blank · 0 comment · 0 complexity · 44ed1f934336ca7e187f0f2b5aff04ff MD5 · raw file

  1. ; Application Server. Layer inserted 2 Sep 06.
  2. ; ideas:
  3. ; def a general notion of apps of which prompt is one, news another
  4. ; give each user a place to store data? A home dir?
  5. ; A user is simply a string: "pg". Use /whoami to test user cookie.
  6. (= hpwfile* "arc/hpw"
  7. oidfile* "arc/openids"
  8. adminfile* "arc/admins"
  9. cookfile* "arc/cooks")
  10. (def asv ((o port 8080))
  11. (load-userinfo)
  12. (serve port))
  13. (def load-userinfo ()
  14. (= hpasswords* (safe-load-table hpwfile*)
  15. openids* (safe-load-table oidfile*)
  16. admins* (map string (errsafe (readfile adminfile*)))
  17. cookie->user* (safe-load-table cookfile*))
  18. (maptable (fn (k v) (= (user->cookie* v) k))
  19. cookie->user*))
  20. ; idea: a bidirectional table, so don't need two vars (and sets)
  21. (= cookie->user* (table) user->cookie* (table) logins* (table))
  22. (def get-user (req)
  23. (let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
  24. (when u (= (logins* u) req!ip))
  25. u))
  26. (mac when-umatch (user req . body)
  27. `(if (is ,user (get-user ,req))
  28. (do ,@body)
  29. (mismatch-message)))
  30. (def mismatch-message ()
  31. (prn "Dead link: users don't match."))
  32. (mac when-umatch/r (user req . body)
  33. `(if (is ,user (get-user ,req))
  34. (do ,@body)
  35. "mismatch"))
  36. (defop mismatch req (mismatch-message))
  37. (mac uform (user req after . body)
  38. `(aform (fn (,req)
  39. (when-umatch ,user ,req
  40. ,after))
  41. ,@body))
  42. (mac urform (user req after . body)
  43. `(arform (fn (,req)
  44. (when-umatch/r ,user ,req
  45. ,after))
  46. ,@body))
  47. ; Like onlink, but checks that user submitting the request is the
  48. ; same it was generated for. For extra protection could log the
  49. ; username and ip addr of every genlink, and check if they match.
  50. (mac ulink (user text . body)
  51. (w/uniq req
  52. `(linkf ,text (,req)
  53. (when-umatch ,user ,req ,@body))))
  54. (defop admin req (admin-gate (get-user req)))
  55. (def admin-gate (u)
  56. (if (admin u)
  57. (admin-page u)
  58. (login-page 'login nil
  59. (fn (u ip) (admin-gate u)))))
  60. (def admin (u) (and u (mem u admins*)))
  61. (def user-exists (u) (and u (hpasswords* u) u))
  62. (def admin-page (user . msg)
  63. (whitepage
  64. (prbold "Admin: ")
  65. (hspace 20)
  66. (pr user " | ")
  67. (w/link (do (logout-user user)
  68. (whitepage (pr "Bye " user ".")))
  69. (pr "logout"))
  70. (when msg (hspace 10) (map pr msg))
  71. (br2)
  72. (aform (fn (req)
  73. (when-umatch user req
  74. (with (u (arg req "u") p (arg req "p"))
  75. (if (or (no u) (no p) (is u "") (is p ""))
  76. (pr "Bad data.")
  77. (user-exists u)
  78. (admin-page user "User already exists: " u)
  79. (do (create-acct u p)
  80. (admin-page user))))))
  81. (pwfields "create (server) account"))))
  82. (def cook-user (user)
  83. (let id (new-user-cookie)
  84. (= (cookie->user* id) user
  85. (user->cookie* user) id)
  86. (save-table cookie->user* cookfile*)
  87. id))
  88. ; Unique-ids are only unique per server invocation.
  89. (def new-user-cookie ()
  90. (let id (unique-id)
  91. (if (cookie->user* id) (new-user-cookie) id)))
  92. (def logout-user (user)
  93. (wipe (logins* user))
  94. (wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
  95. (save-table cookie->user* cookfile*))
  96. (def create-acct (user pw)
  97. (set (dc-usernames* (downcase user)))
  98. (set-pw user pw))
  99. (def disable-acct (user)
  100. (set-pw user (rand-string 20))
  101. (logout-user user))
  102. (def set-pw (user pw)
  103. (= (hpasswords* user) (and pw (shash pw)))
  104. (save-table hpasswords* hpwfile*))
  105. (def hello-page (user ip)
  106. (whitepage (prs "hello" user "at" ip)))
  107. (defop login req (login-page 'login))
  108. ; switch is one of: register, login, both
  109. ; afterward is either a function on the newly created username and
  110. ; ip address, in which case it is called to generate the next page
  111. ; after a successful login, or a pair of (function url), which means
  112. ; call the function, then redirect to the url.
  113. ; classic example of something that should just "return" a val
  114. ; via a continuation rather than going to a new page.
  115. (def login-page (switch (o msg nil) (o afterward hello-page))
  116. (whitepage
  117. (pagemessage msg)
  118. (when (in switch 'login 'both)
  119. (login-form "Login" switch login-handler afterward)
  120. (hook 'login-form afterward)
  121. (br2))
  122. (when (in switch 'register 'both)
  123. (login-form "Create Account" switch create-handler afterward))))
  124. (def login-form (label switch handler afterward)
  125. (prbold label)
  126. (br2)
  127. (fnform (fn (req) (handler req switch afterward))
  128. (fn () (pwfields (downcase label)))
  129. (acons afterward)))
  130. (def login-handler (req switch afterward)
  131. (logout-user (get-user req))
  132. (aif (good-login (arg req "u") (arg req "p") req!ip)
  133. (login it req!ip (user->cookie* it) afterward)
  134. (failed-login switch "Bad login." afterward)))
  135. (def create-handler (req switch afterward)
  136. (logout-user (get-user req))
  137. (with (user (arg req "u") pw (arg req "p"))
  138. (aif (bad-newacct user pw)
  139. (failed-login switch it afterward)
  140. (do (create-acct user pw)
  141. (login user req!ip (cook-user user) afterward)))))
  142. (def login (user ip cookie afterward)
  143. (= (logins* user) ip)
  144. (prcookie cookie)
  145. (if (acons afterward)
  146. (let (f url) afterward
  147. (f user ip)
  148. url)
  149. (do (prn)
  150. (afterward user ip))))
  151. (def failed-login (switch msg afterward)
  152. (if (acons afterward)
  153. (flink (fn ignore (login-page switch msg afterward)))
  154. (do (prn)
  155. (login-page switch msg afterward))))
  156. (def prcookie (cook)
  157. (prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
  158. (def pwfields ((o label "login"))
  159. (inputs u username 20 nil
  160. p password 20 nil)
  161. (br)
  162. (submit label))
  163. (= good-logins* (queue) bad-logins* (queue))
  164. (def good-login (user pw ip)
  165. (let record (list (seconds) ip user)
  166. (if (and user pw (aand (shash pw) (is it (hpasswords* user))))
  167. (do (unless (user->cookie* user) (cook-user user))
  168. (enq-limit record good-logins*)
  169. user)
  170. (do (enq-limit record bad-logins*)
  171. nil))))
  172. ; Create a file in case people have quote chars in their pws. I can't
  173. ; believe there's no way to just send the chars.
  174. (def shash (str)
  175. (let fname (+ "/tmp/shash" (rand-string 10))
  176. (w/outfile f fname (disp str f))
  177. (let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
  178. (do1 (cut res 0 (- (len res) 1))
  179. (rmfile fname)))))
  180. (= dc-usernames* (table))
  181. (def username-taken (user)
  182. (when (empty dc-usernames*)
  183. (each (k v) hpasswords*
  184. (set (dc-usernames* (downcase k)))))
  185. (dc-usernames* (downcase user)))
  186. (def bad-newacct (user pw)
  187. (if (no (goodname user 2 15))
  188. "Usernames can only contain letters, digits, dashes and
  189. underscores, and should be between 2 and 15 characters long.
  190. Please choose another."
  191. (username-taken user)
  192. "That username is taken. Please choose another."
  193. (or (no pw) (< (len pw) 4))
  194. "Passwords should be a least 4 characters long. Please
  195. choose another."
  196. nil))
  197. (def goodname (str (o min 1) (o max nil))
  198. (and (isa str 'string)
  199. (>= (len str) min)
  200. (~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
  201. str)
  202. (isnt (str 0) #\-)
  203. (or (no max) (<= (len str) max))
  204. str))
  205. (defop logout req
  206. (aif (get-user req)
  207. (do (logout-user it)
  208. (pr "Logged out."))
  209. (pr "You were not logged in.")))
  210. (defop whoami req
  211. (aif (get-user req)
  212. (prs it 'at req!ip)
  213. (do (pr "You are not logged in. ")
  214. (w/link (login-page 'both) (pr "Log in"))
  215. (pr "."))))
  216. (= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
  217. ; Eventually figure out a way to separate type name from format of
  218. ; input field, instead of having e.g. toks and bigtoks
  219. (def varfield (typ id val)
  220. (if (in typ 'string 'string1 'url)
  221. (gentag input type 'text name id value val size formwid*)
  222. (in typ 'num 'int 'posint 'sym)
  223. (gentag input type 'text name id value val size numwid*)
  224. (in typ 'users 'toks)
  225. (gentag input type 'text name id value (tostring (apply prs val))
  226. size formwid*)
  227. (is typ 'sexpr)
  228. (gentag input type 'text name id
  229. value (tostring (map [do (write _) (sp)] val))
  230. size formwid*)
  231. (in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
  232. (let text (if (in typ 'syms 'bigtoks)
  233. (tostring (apply prs val))
  234. (is typ 'lines)
  235. (tostring (apply pr (intersperse #\newline val)))
  236. (in typ 'mdtext 'mdtext2)
  237. (unmarkdown val)
  238. (no val)
  239. ""
  240. val)
  241. (tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
  242. rows (needrows text formwid* 4)
  243. wrap 'virtual
  244. style (if (is typ 'doc) "font-size:8.5pt")
  245. name id)
  246. (prn) ; needed or 1 initial newline gets chopped off
  247. (pr text))
  248. (when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
  249. (pr " ")
  250. (tag (font size -2)
  251. (link "help" formatdoc-url* (gray 175)))))
  252. (caris typ 'choice)
  253. (menu id (cddr typ) val)
  254. (is typ 'yesno)
  255. (menu id '("yes" "no") (if val "yes" "no"))
  256. (is typ 'hexcol)
  257. (gentag input type 'text name id value val)
  258. (is typ 'time)
  259. (gentag input type 'text name id value (if val (english-time val) ""))
  260. (is typ 'date)
  261. (gentag input type 'text name id value (if val (english-date val) ""))
  262. (err "unknown varfield type" typ)))
  263. (def text-rows (text wid (o pad 3))
  264. (+ (trunc (/ (len text) (* wid .8))) pad))
  265. (def needrows (text cols (o pad 0))
  266. (+ pad (max (+ 1 (count #\newline text))
  267. (roundup (/ (len text) (- cols 5))))))
  268. (def varline (typ id val (o liveurls))
  269. (if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
  270. (is typ 'lines) (map prn val)
  271. (is typ 'yesno) (pr (if val 'yes 'no))
  272. (caris typ 'choice) (varline (cadr typ) nil val)
  273. (is typ 'url) (if (and liveurls (valid-url val))
  274. (link val val)
  275. (pr val))
  276. (text-type typ) (pr (or val ""))
  277. (pr val)))
  278. (def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
  279. ; Newlines in forms come back as /r/n. Only want the /ns. Currently
  280. ; remove the /rs in individual cases below. Could do it in aform or
  281. ; even in the parsing of http requests, in the server.
  282. ; Need the calls to striptags so that news users can't get html
  283. ; into a title or comment by editing it. If want a form that
  284. ; can take html, just create another typ for it.
  285. (def readvar (typ str (o fail nil))
  286. (case (carif typ)
  287. string (striptags str)
  288. string1 (if (blank str) fail (striptags str))
  289. url (if (blank str) "" (valid-url str) (clean-url str) fail)
  290. num (let n (saferead str) (if (number n) n fail))
  291. int (let n (saferead str)
  292. (if (number n) (round n) fail))
  293. posint (let n (saferead str)
  294. (if (and (number n) (> n 0)) (round n) fail))
  295. text (striptags str)
  296. doc (striptags str)
  297. mdtext (md-from-form str)
  298. mdtext2 (md-from-form str t) ; for md with no links
  299. sym (or (sym:car:tokens str) fail)
  300. syms (map sym (tokens str))
  301. sexpr (errsafe (readall str))
  302. users (rem [no (goodname _)] (tokens str))
  303. toks (tokens str)
  304. bigtoks (tokens str)
  305. lines (lines str)
  306. choice (readvar (cadr typ) str)
  307. yesno (is str "yes")
  308. hexcol (if (hex>color str) str fail)
  309. time (or (errsafe (parse-time str)) fail)
  310. date (or (errsafe (parse-date str)) fail)
  311. (err "unknown readvar type" typ)))
  312. ; dates should be tagged date, and just redefine <
  313. (def varcompare (typ)
  314. (if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
  315. (fn (x y) (> (len x) (len y)))
  316. (is typ 'date)
  317. (fn (x y)
  318. (or (no y) (and x (date< x y))))
  319. (fn (x y)
  320. (or (empty y) (and (~empty x) (< x y))))))
  321. ; (= fail* (uniq))
  322. (def fail* ()) ; coudn't possibly come back from a form
  323. ; Takes a list of fields of the form (type label value view modify) and
  324. ; a fn f and generates a form such that when submitted (f label newval)
  325. ; will be called for each valid value. Finally done is called.
  326. (def vars-form (user fields f done (o button "update") (o lasts))
  327. (taform lasts
  328. (if (all [no (_ 4)] fields)
  329. (fn (req))
  330. (fn (req)
  331. (when-umatch user req
  332. (each (k v) req!args
  333. (let name (sym k)
  334. (awhen (find [is (cadr _) name] fields)
  335. ; added sho to fix bug
  336. (let (typ id val sho mod) it
  337. (when (and mod v)
  338. (let newval (readvar typ v fail*)
  339. (unless (is newval fail*)
  340. (f name newval))))))))
  341. (done))))
  342. (tab
  343. (showvars fields))
  344. (unless (all [no (_ 4)] fields) ; no modifiable fields
  345. (br)
  346. (submit button))))
  347. (def showvars (fields (o liveurls))
  348. (each (typ id val view mod question) fields
  349. (when view
  350. (when question
  351. (tr (td (prn question))))
  352. (tr (unless question (tag (td valign 'top) (pr id ":")))
  353. (td (if mod
  354. (varfield typ id val)
  355. (varline typ id val liveurls))))
  356. (prn))))
  357. ; http://daringfireball.net/projects/markdown/syntax
  358. (def md-from-form (str (o nolinks))
  359. (markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
  360. (def markdown (s (o maxurl) (o nolinks))
  361. (let ital nil
  362. (tostring
  363. (forlen i s
  364. (iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
  365. (do (pr "<p><pre><code>")
  366. (let cb (code-block s (- newi spaces 1))
  367. (pr cb)
  368. (= i (+ (- newi spaces 1) (len cb))))
  369. (pr "</code></pre>"))
  370. (iflet newi (parabreak s i (if (is i 0) 1 0))
  371. (do (unless (is i 0) (pr "<p>"))
  372. (= i (- newi 1)))
  373. (and (is (s i) #\*)
  374. (or ital
  375. (atend i s)
  376. (and (~whitec (s (+ i 1)))
  377. (pos #\* s (+ i 1)))))
  378. (do (pr (if ital "</i>" "<i>"))
  379. (= ital (no ital)))
  380. (and (no nolinks)
  381. (or (litmatch "http://" s i)
  382. (litmatch "https://" s i)))
  383. (withs (n (urlend s i)
  384. url (clean-url (cut s i n)))
  385. (tag (a href url rel 'nofollow)
  386. (pr (if (no maxurl) url (ellipsize url maxurl))))
  387. (= i (- n 1)))
  388. (writec (s i))))))))
  389. (def indented-code (s i (o newlines 0) (o spaces 0))
  390. (let c (s i)
  391. (if (nonwhite c)
  392. (if (and (> newlines 1) (> spaces 1))
  393. (list i spaces)
  394. nil)
  395. (atend i s)
  396. nil
  397. (is c #\newline)
  398. (indented-code s (+ i 1) (+ newlines 1) 0)
  399. (indented-code s (+ i 1) newlines (+ spaces 1)))))
  400. ; If i is start a paragraph break, returns index of start of next para.
  401. (def parabreak (s i (o newlines 0))
  402. (let c (s i)
  403. (if (or (nonwhite c) (atend i s))
  404. (if (> newlines 1) i nil)
  405. (parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
  406. ; Returns the indices of the next paragraph break in s, if any.
  407. (def next-parabreak (s i)
  408. (unless (atend i s)
  409. (aif (parabreak s i)
  410. (list i it)
  411. (next-parabreak s (+ i 1)))))
  412. (def paras (s (o i 0))
  413. (if (atend i s)
  414. nil
  415. (iflet (endthis startnext) (next-parabreak s i)
  416. (cons (cut s i endthis)
  417. (paras s startnext))
  418. (list (trim (cut s i) 'end)))))
  419. ; Returns the index of the first char not part of the url beginning
  420. ; at i, or len of string if url goes all the way to the end.
  421. ; Note that > immediately after a url (http://foo.com>) will cause
  422. ; an odd result, because the > gets escaped to something beginning
  423. ; with &, which is treated as part of the url. Perhaps the answer
  424. ; is just to esc-tags after markdown instead of before.
  425. ; Treats a delimiter as part of a url if it is (a) an open delimiter
  426. ; not followed by whitespace or eos, or (b) a close delimiter
  427. ; balancing a previous open delimiter.
  428. (def urlend (s i (o indelim))
  429. (let c (s i)
  430. (if (atend i s)
  431. (if ((orf punc whitec opendelim) c)
  432. i
  433. (closedelim c)
  434. (if indelim (+ i 1) i)
  435. (+ i 1))
  436. (if (or (whitec c)
  437. (and (punc c) (whitec (s (+ i 1))))
  438. (and ((orf whitec punc) (s (+ i 1)))
  439. (or (opendelim c)
  440. (and (closedelim c) (no indelim)))))
  441. i
  442. (urlend s (+ i 1) (or (opendelim c)
  443. (and indelim (no (closedelim c)))))))))
  444. (def opendelim (c) (in c #\< #\( #\[ #\{))
  445. (def closedelim (c) (in c #\> #\) #\] #\}))
  446. (def code-block (s i)
  447. (tostring
  448. (until (let left (- (len s) i 1)
  449. (or (is left 0)
  450. (and (> left 2)
  451. (is (s (+ i 1)) #\newline)
  452. (nonwhite (s (+ i 2))))))
  453. (writec (s (++ i))))))
  454. (def unmarkdown (s)
  455. (tostring
  456. (forlen i s
  457. (if (litmatch "<p>" s i)
  458. (do (++ i 2)
  459. (unless (is i 2) (pr "\n\n")))
  460. (litmatch "<i>" s i)
  461. (do (++ i 2) (pr #\*))
  462. (litmatch "</i>" s i)
  463. (do (++ i 3) (pr #\*))
  464. (litmatch "<a href=" s i)
  465. (let endurl (posmatch [in _ #\> #\space] s (+ i 9))
  466. (if endurl
  467. (do (pr (cut s (+ i 9) (- endurl 1)))
  468. (= i (aif (posmatch "</a>" s endurl)
  469. (+ it 3)
  470. endurl)))
  471. (writec (s i))))
  472. (litmatch "<pre><code>" s i)
  473. (awhen (findsubseq "</code></pre>" s (+ i 12))
  474. (pr (cut s (+ i 11) it))
  475. (= i (+ it 12)))
  476. (writec (s i))))))
  477. (def english-time (min)
  478. (let n (mod min 720)
  479. (string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
  480. ":"
  481. (let m (mod n 60)
  482. (if (is m 0) "00"
  483. (< m 10) (string "0" m)
  484. m))
  485. (if (is min 0) " midnight"
  486. (is min 720) " noon"
  487. (>= min 720) " pm"
  488. " am"))))
  489. (def parse-time (s)
  490. (let (nums (o label "")) (halve s letter)
  491. (with ((h (o m 0)) (map int (tokens nums ~digit))
  492. cleanlabel (downcase (rem ~alphadig label)))
  493. (+ (* (if (is h 12)
  494. (if (in cleanlabel "am" "midnight")
  495. 0
  496. 12)
  497. (is cleanlabel "am")
  498. h
  499. (+ h 12))
  500. 60)
  501. m))))
  502. (= months* '("January" "February" "March" "April" "May" "June" "July"
  503. "August" "September" "October" "November" "December"))
  504. (def english-date ((y m d))
  505. (string d " " (months* (- m 1)) " " y))
  506. (= month-names* (obj "january" 1 "jan" 1
  507. "february" 2 "feb" 2
  508. "march" 3 "mar" 3
  509. "april" 4 "apr" 4
  510. "may" 5
  511. "june" 6 "jun" 6
  512. "july" 7 "jul" 7
  513. "august" 8 "aug" 8
  514. "september" 9 "sept" 9 "sep" 9
  515. "october" 10 "oct" 10
  516. "november" 11 "nov" 11
  517. "december" 12 "dec" 12))
  518. (def monthnum (s) (month-names* (downcase s)))
  519. ; Doesn't work for BC dates.
  520. (def parse-date (s)
  521. (let nums (date-nums s)
  522. (if (valid-date nums)
  523. nums
  524. (err (string "Invalid date: " s)))))
  525. (def date-nums (s)
  526. (with ((ynow mnow dnow) (date)
  527. toks (tokens s ~alphadig))
  528. (if (all [all digit _] toks)
  529. (let nums (map int toks)
  530. (case (len nums)
  531. 1 (list ynow mnow (car nums))
  532. 2 (iflet d (find [> _ 12] nums)
  533. (list ynow (find [isnt _ d] nums) d)
  534. (cons ynow nums))
  535. (if (> (car nums) 31)
  536. (firstn 3 nums)
  537. (rev (firstn 3 nums)))))
  538. ([all digit _] (car toks))
  539. (withs ((ds ms ys) toks
  540. d (int ds))
  541. (aif (monthnum ms)
  542. (list (or (errsafe (int ys)) ynow)
  543. it
  544. d)
  545. nil))
  546. (monthnum (car toks))
  547. (let (ms ds ys) toks
  548. (aif (errsafe (int ds))
  549. (list (or (errsafe (int ys)) ynow)
  550. (monthnum (car toks))
  551. it)
  552. nil))
  553. nil)))
  554. ; To be correct needs to know days per month, and about leap years
  555. (def valid-date ((y m d))
  556. (and y m d
  557. (< 0 m 13)
  558. (< 0 d 32)))
  559. (mac defopl (name parm . body)
  560. `(defop ,name ,parm
  561. (if (get-user ,parm)
  562. (do ,@body)
  563. (login-page 'both
  564. "You need to be logged in to do that."
  565. (list (fn (u ip))
  566. (string ',name (reassemble-args ,parm)))))))