PageRenderTime 38ms CodeModel.GetById 18ms app.highlight 8ms RepoModel.GetById 2ms app.codeStats 0ms

/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
  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