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