672 lines
22 KiB
Plaintext
672 lines
22 KiB
Plaintext
; Application Server. Layer inserted 2 Sep 06.
|
|
|
|
; ideas:
|
|
; def a general notion of apps of which prompt is one, news another
|
|
; give each user a place to store data? A home dir?
|
|
|
|
; A user is simply a string: "pg". Use /whoami to test user cookie.
|
|
|
|
(= hpwfile* "arc/hpw"
|
|
oidfile* "arc/openids"
|
|
adminfile* "arc/admins"
|
|
cookfile* "arc/cooks")
|
|
|
|
(def asv ((o port 8080))
|
|
(load-userinfo)
|
|
(serve port))
|
|
|
|
(def load-userinfo ()
|
|
(= hpasswords* (safe-load-table hpwfile*)
|
|
openids* (safe-load-table oidfile*)
|
|
admins* (map string (errsafe (readfile adminfile*)))
|
|
cookie->user* (safe-load-table cookfile*))
|
|
(maptable (fn (k v) (= (user->cookie* v) k))
|
|
cookie->user*))
|
|
|
|
; idea: a bidirectional table, so don't need two vars (and sets)
|
|
|
|
(= cookie->user* (table) user->cookie* (table) logins* (table))
|
|
|
|
(def get-user (req)
|
|
(let u (aand (alref req!cooks "user") (cookie->user* (sym it)))
|
|
(when u (= (logins* u) req!ip))
|
|
u))
|
|
|
|
(mac when-umatch (user req . body)
|
|
`(if (is ,user (get-user ,req))
|
|
(do ,@body)
|
|
(mismatch-message)))
|
|
|
|
(def mismatch-message ()
|
|
(prn "Dead link: users don't match."))
|
|
|
|
(mac when-umatch/r (user req . body)
|
|
`(if (is ,user (get-user ,req))
|
|
(do ,@body)
|
|
"mismatch"))
|
|
|
|
(defop mismatch req (mismatch-message))
|
|
|
|
(mac uform (user req after . body)
|
|
`(aform (fn (,req)
|
|
(when-umatch ,user ,req
|
|
,after))
|
|
,@body))
|
|
|
|
(mac urform (user req after . body)
|
|
`(arform (fn (,req)
|
|
(when-umatch/r ,user ,req
|
|
,after))
|
|
,@body))
|
|
|
|
; Like onlink, but checks that user submitting the request is the
|
|
; same it was generated for. For extra protection could log the
|
|
; username and ip addr of every genlink, and check if they match.
|
|
|
|
(mac ulink (user text . body)
|
|
(w/uniq req
|
|
`(linkf ,text (,req)
|
|
(when-umatch ,user ,req ,@body))))
|
|
|
|
|
|
(defop admin req (admin-gate (get-user req)))
|
|
|
|
(def admin-gate (u)
|
|
(if (admin u)
|
|
(admin-page u)
|
|
(login-page 'login nil
|
|
(fn (u ip) (admin-gate u)))))
|
|
|
|
(def admin (u) (and u (mem u admins*)))
|
|
|
|
(def user-exists (u) (and u (hpasswords* u) u))
|
|
|
|
(def admin-page (user . msg)
|
|
(whitepage
|
|
(prbold "Admin: ")
|
|
(hspace 20)
|
|
(pr user " | ")
|
|
(w/link (do (logout-user user)
|
|
(whitepage (pr "Bye " user ".")))
|
|
(pr "logout"))
|
|
(when msg (hspace 10) (map pr msg))
|
|
(br2)
|
|
(aform (fn (req)
|
|
(when-umatch user req
|
|
(with (u (arg req "u") p (arg req "p"))
|
|
(if (or (no u) (no p) (is u "") (is p ""))
|
|
(pr "Bad data.")
|
|
(user-exists u)
|
|
(admin-page user "User already exists: " u)
|
|
(do (create-acct u p)
|
|
(admin-page user))))))
|
|
(pwfields "create (server) account"))))
|
|
|
|
(def cook-user (user)
|
|
(let id (new-user-cookie)
|
|
(= (cookie->user* id) user
|
|
(user->cookie* user) id)
|
|
(save-table cookie->user* cookfile*)
|
|
id))
|
|
|
|
; Unique-ids are only unique per server invocation.
|
|
|
|
(def new-user-cookie ()
|
|
(let id (unique-id)
|
|
(if (cookie->user* id) (new-user-cookie) id)))
|
|
|
|
(def logout-user (user)
|
|
(wipe (logins* user))
|
|
(wipe (cookie->user* (user->cookie* user)) (user->cookie* user))
|
|
(save-table cookie->user* cookfile*))
|
|
|
|
(def create-acct (user pw)
|
|
(set (dc-usernames* (downcase user)))
|
|
(set-pw user pw))
|
|
|
|
(def disable-acct (user)
|
|
(set-pw user (rand-string 20))
|
|
(logout-user user))
|
|
|
|
(def set-pw (user pw)
|
|
(= (hpasswords* user) (and pw (shash pw)))
|
|
(save-table hpasswords* hpwfile*))
|
|
|
|
(def hello-page (user ip)
|
|
(whitepage (prs "hello" user "at" ip)))
|
|
|
|
(defop login req (login-page 'login))
|
|
|
|
; switch is one of: register, login, both
|
|
|
|
; afterward is either a function on the newly created username and
|
|
; ip address, in which case it is called to generate the next page
|
|
; after a successful login, or a pair of (function url), which means
|
|
; call the function, then redirect to the url.
|
|
|
|
; classic example of something that should just "return" a val
|
|
; via a continuation rather than going to a new page.
|
|
|
|
(def login-page (switch (o msg nil) (o afterward hello-page))
|
|
(whitepage
|
|
(pagemessage msg)
|
|
(when (in switch 'login 'both)
|
|
(login-form "Login" switch login-handler afterward)
|
|
(hook 'login-form afterward)
|
|
(br2))
|
|
(when (in switch 'register 'both)
|
|
(login-form "Create Account" switch create-handler afterward))))
|
|
|
|
(def login-form (label switch handler afterward)
|
|
(prbold label)
|
|
(br2)
|
|
(fnform (fn (req) (handler req switch afterward))
|
|
(fn () (pwfields (downcase label)))
|
|
(acons afterward)))
|
|
|
|
(def login-handler (req switch afterward)
|
|
(logout-user (get-user req))
|
|
(aif (good-login (arg req "u") (arg req "p") req!ip)
|
|
(login it req!ip (user->cookie* it) afterward)
|
|
(failed-login switch "Bad login." afterward)))
|
|
|
|
(def create-handler (req switch afterward)
|
|
(logout-user (get-user req))
|
|
(with (user (arg req "u") pw (arg req "p"))
|
|
(aif (bad-newacct user pw)
|
|
(failed-login switch it afterward)
|
|
(do (create-acct user pw)
|
|
(login user req!ip (cook-user user) afterward)))))
|
|
|
|
(def login (user ip cookie afterward)
|
|
(= (logins* user) ip)
|
|
(prcookie cookie)
|
|
(if (acons afterward)
|
|
(let (f url) afterward
|
|
(f user ip)
|
|
url)
|
|
(do (prn)
|
|
(afterward user ip))))
|
|
|
|
(def failed-login (switch msg afterward)
|
|
(if (acons afterward)
|
|
(flink (fn ignore (login-page switch msg afterward)))
|
|
(do (prn)
|
|
(login-page switch msg afterward))))
|
|
|
|
(def prcookie (cook)
|
|
(prn "Set-Cookie: user=" cook "; expires=Sun, 17-Jan-2038 19:14:07 GMT"))
|
|
|
|
(def pwfields ((o label "login"))
|
|
(inputs u username 20 nil
|
|
p password 20 nil)
|
|
(br)
|
|
(submit label))
|
|
|
|
(= good-logins* (queue) bad-logins* (queue))
|
|
|
|
(def good-login (user pw ip)
|
|
(let record (list (seconds) ip user)
|
|
(if (and user pw (aand (shash pw) (is it (hpasswords* user))))
|
|
(do (unless (user->cookie* user) (cook-user user))
|
|
(enq-limit record good-logins*)
|
|
user)
|
|
(do (enq-limit record bad-logins*)
|
|
nil))))
|
|
|
|
; Create a file in case people have quote chars in their pws. I can't
|
|
; believe there's no way to just send the chars.
|
|
|
|
(def shash (str)
|
|
(let fname (+ "/tmp/shash" (rand-string 10))
|
|
(w/outfile f fname (disp str f))
|
|
(let res (tostring (system (+ "openssl dgst -sha1 <" fname)))
|
|
(do1 (cut res 0 (- (len res) 1))
|
|
(rmfile fname)))))
|
|
|
|
(= dc-usernames* (table))
|
|
|
|
(def username-taken (user)
|
|
(when (empty dc-usernames*)
|
|
(each (k v) hpasswords*
|
|
(set (dc-usernames* (downcase k)))))
|
|
(dc-usernames* (downcase user)))
|
|
|
|
(def bad-newacct (user pw)
|
|
(if (no (goodname user 2 15))
|
|
"Usernames can only contain letters, digits, dashes and
|
|
underscores, and should be between 2 and 15 characters long.
|
|
Please choose another."
|
|
(username-taken user)
|
|
"That username is taken. Please choose another."
|
|
(or (no pw) (< (len pw) 4))
|
|
"Passwords should be a least 4 characters long. Please
|
|
choose another."
|
|
nil))
|
|
|
|
(def goodname (str (o min 1) (o max nil))
|
|
(and (isa str 'string)
|
|
(>= (len str) min)
|
|
(~find (fn (c) (no (or (alphadig c) (in c #\- #\_))))
|
|
str)
|
|
(isnt (str 0) #\-)
|
|
(or (no max) (<= (len str) max))
|
|
str))
|
|
|
|
(defop logout req
|
|
(aif (get-user req)
|
|
(do (logout-user it)
|
|
(pr "Logged out."))
|
|
(pr "You were not logged in.")))
|
|
|
|
(defop whoami req
|
|
(aif (get-user req)
|
|
(prs it 'at req!ip)
|
|
(do (pr "You are not logged in. ")
|
|
(w/link (login-page 'both) (pr "Log in"))
|
|
(pr "."))))
|
|
|
|
|
|
(= formwid* 60 bigformwid* 80 numwid* 16 formatdoc-url* nil)
|
|
|
|
; Eventually figure out a way to separate type name from format of
|
|
; input field, instead of having e.g. toks and bigtoks
|
|
|
|
(def varfield (typ id val)
|
|
(if (in typ 'string 'string1 'url)
|
|
(gentag input type 'text name id value val size formwid*)
|
|
(in typ 'num 'int 'posint 'sym)
|
|
(gentag input type 'text name id value val size numwid*)
|
|
(in typ 'users 'toks)
|
|
(gentag input type 'text name id value (tostring (apply prs val))
|
|
size formwid*)
|
|
(is typ 'sexpr)
|
|
(gentag input type 'text name id
|
|
value (tostring (map [do (write _) (sp)] val))
|
|
size formwid*)
|
|
(in typ 'syms 'text 'doc 'mdtext 'mdtext2 'lines 'bigtoks)
|
|
(let text (if (in typ 'syms 'bigtoks)
|
|
(tostring (apply prs val))
|
|
(is typ 'lines)
|
|
(tostring (apply pr (intersperse #\newline val)))
|
|
(in typ 'mdtext 'mdtext2)
|
|
(unmarkdown val)
|
|
(no val)
|
|
""
|
|
val)
|
|
(tag (textarea cols (if (is typ 'doc) bigformwid* formwid*)
|
|
rows (needrows text formwid* 4)
|
|
wrap 'virtual
|
|
style (if (is typ 'doc) "font-size:8.5pt")
|
|
name id)
|
|
(prn) ; needed or 1 initial newline gets chopped off
|
|
(pr text))
|
|
(when (and formatdoc-url* (in typ 'mdtext 'mdtext2))
|
|
(pr " ")
|
|
(tag (font size -2)
|
|
(link "help" formatdoc-url* (gray 175)))))
|
|
(caris typ 'choice)
|
|
(menu id (cddr typ) val)
|
|
(is typ 'yesno)
|
|
(menu id '("yes" "no") (if val "yes" "no"))
|
|
(is typ 'hexcol)
|
|
(gentag input type 'text name id value val)
|
|
(is typ 'time)
|
|
(gentag input type 'text name id value (if val (english-time val) ""))
|
|
(is typ 'date)
|
|
(gentag input type 'text name id value (if val (english-date val) ""))
|
|
(err "unknown varfield type" typ)))
|
|
|
|
(def text-rows (text wid (o pad 3))
|
|
(+ (trunc (/ (len text) (* wid .8))) pad))
|
|
|
|
(def needrows (text cols (o pad 0))
|
|
(+ pad (max (+ 1 (count #\newline text))
|
|
(roundup (/ (len text) (- cols 5))))))
|
|
|
|
(def varline (typ id val (o liveurls))
|
|
(if (in typ 'users 'syms 'toks 'bigtoks) (apply prs val)
|
|
(is typ 'lines) (map prn val)
|
|
(is typ 'yesno) (pr (if val 'yes 'no))
|
|
(caris typ 'choice) (varline (cadr typ) nil val)
|
|
(is typ 'url) (if (and liveurls (valid-url val))
|
|
(link val val)
|
|
(pr val))
|
|
(text-type typ) (pr (or val ""))
|
|
(pr val)))
|
|
|
|
(def text-type (typ) (in typ 'string 'string1 'url 'text 'mdtext 'mdtext2))
|
|
|
|
; Newlines in forms come back as /r/n. Only want the /ns. Currently
|
|
; remove the /rs in individual cases below. Could do it in aform or
|
|
; even in the parsing of http requests, in the server.
|
|
|
|
; Need the calls to striptags so that news users can't get html
|
|
; into a title or comment by editing it. If want a form that
|
|
; can take html, just create another typ for it.
|
|
|
|
(def readvar (typ str (o fail nil))
|
|
(case (carif typ)
|
|
string (striptags str)
|
|
string1 (if (blank str) fail (striptags str))
|
|
url (if (blank str) "" (valid-url str) (clean-url str) fail)
|
|
num (let n (saferead str) (if (number n) n fail))
|
|
int (let n (saferead str)
|
|
(if (number n) (round n) fail))
|
|
posint (let n (saferead str)
|
|
(if (and (number n) (> n 0)) (round n) fail))
|
|
text (striptags str)
|
|
doc (striptags str)
|
|
mdtext (md-from-form str)
|
|
mdtext2 (md-from-form str t) ; for md with no links
|
|
sym (or (sym:car:tokens str) fail)
|
|
syms (map sym (tokens str))
|
|
sexpr (errsafe (readall str))
|
|
users (rem [no (goodname _)] (tokens str))
|
|
toks (tokens str)
|
|
bigtoks (tokens str)
|
|
lines (lines str)
|
|
choice (readvar (cadr typ) str)
|
|
yesno (is str "yes")
|
|
hexcol (if (hex>color str) str fail)
|
|
time (or (errsafe (parse-time str)) fail)
|
|
date (or (errsafe (parse-date str)) fail)
|
|
(err "unknown readvar type" typ)))
|
|
|
|
; dates should be tagged date, and just redefine <
|
|
|
|
(def varcompare (typ)
|
|
(if (in typ 'syms 'sexpr 'users 'toks 'bigtoks 'lines 'hexcol)
|
|
(fn (x y) (> (len x) (len y)))
|
|
(is typ 'date)
|
|
(fn (x y)
|
|
(or (no y) (and x (date< x y))))
|
|
(fn (x y)
|
|
(or (empty y) (and (~empty x) (< x y))))))
|
|
|
|
|
|
; (= fail* (uniq))
|
|
|
|
(def fail* ()) ; coudn't possibly come back from a form
|
|
|
|
; Takes a list of fields of the form (type label value view modify) and
|
|
; a fn f and generates a form such that when submitted (f label newval)
|
|
; will be called for each valid value. Finally done is called.
|
|
|
|
(def vars-form (user fields f done (o button "update") (o lasts))
|
|
(taform lasts
|
|
(if (all [no (_ 4)] fields)
|
|
(fn (req))
|
|
(fn (req)
|
|
(when-umatch user req
|
|
(each (k v) req!args
|
|
(let name (sym k)
|
|
(awhen (find [is (cadr _) name] fields)
|
|
; added sho to fix bug
|
|
(let (typ id val sho mod) it
|
|
(when (and mod v)
|
|
(let newval (readvar typ v fail*)
|
|
(unless (is newval fail*)
|
|
(f name newval))))))))
|
|
(done))))
|
|
(tab
|
|
(showvars fields))
|
|
(unless (all [no (_ 4)] fields) ; no modifiable fields
|
|
(br)
|
|
(submit button))))
|
|
|
|
(def showvars (fields (o liveurls))
|
|
(each (typ id val view mod question) fields
|
|
(when view
|
|
(when question
|
|
(tr (td (prn question))))
|
|
(tr (unless question (tag (td valign 'top) (pr id ":")))
|
|
(td (if mod
|
|
(varfield typ id val)
|
|
(varline typ id val liveurls))))
|
|
(prn))))
|
|
|
|
; http://daringfireball.net/projects/markdown/syntax
|
|
|
|
(def md-from-form (str (o nolinks))
|
|
(markdown (trim (rem #\return (esc-tags str)) 'end) 60 nolinks))
|
|
|
|
(def markdown (s (o maxurl) (o nolinks))
|
|
(let ital nil
|
|
(tostring
|
|
(forlen i s
|
|
(iflet (newi spaces) (indented-code s i (if (is i 0) 2 0))
|
|
(do (pr "<p><pre><code>")
|
|
(let cb (code-block s (- newi spaces 1))
|
|
(pr cb)
|
|
(= i (+ (- newi spaces 1) (len cb))))
|
|
(pr "</code></pre>"))
|
|
(iflet newi (parabreak s i (if (is i 0) 1 0))
|
|
(do (unless (is i 0) (pr "<p>"))
|
|
(= i (- newi 1)))
|
|
(and (is (s i) #\*)
|
|
(or ital
|
|
(atend i s)
|
|
(and (~whitec (s (+ i 1)))
|
|
(pos #\* s (+ i 1)))))
|
|
(do (pr (if ital "</i>" "<i>"))
|
|
(= ital (no ital)))
|
|
(and (no nolinks)
|
|
(or (litmatch "http://" s i)
|
|
(litmatch "https://" s i)))
|
|
(withs (n (urlend s i)
|
|
url (clean-url (cut s i n)))
|
|
(tag (a href url rel 'nofollow)
|
|
(pr (if (no maxurl) url (ellipsize url maxurl))))
|
|
(= i (- n 1)))
|
|
(writec (s i))))))))
|
|
|
|
(def indented-code (s i (o newlines 0) (o spaces 0))
|
|
(let c (s i)
|
|
(if (nonwhite c)
|
|
(if (and (> newlines 1) (> spaces 1))
|
|
(list i spaces)
|
|
nil)
|
|
(atend i s)
|
|
nil
|
|
(is c #\newline)
|
|
(indented-code s (+ i 1) (+ newlines 1) 0)
|
|
(indented-code s (+ i 1) newlines (+ spaces 1)))))
|
|
|
|
; If i is start a paragraph break, returns index of start of next para.
|
|
|
|
(def parabreak (s i (o newlines 0))
|
|
(let c (s i)
|
|
(if (or (nonwhite c) (atend i s))
|
|
(if (> newlines 1) i nil)
|
|
(parabreak s (+ i 1) (+ newlines (if (is c #\newline) 1 0))))))
|
|
|
|
; Returns the indices of the next paragraph break in s, if any.
|
|
|
|
(def next-parabreak (s i)
|
|
(unless (atend i s)
|
|
(aif (parabreak s i)
|
|
(list i it)
|
|
(next-parabreak s (+ i 1)))))
|
|
|
|
(def paras (s (o i 0))
|
|
(if (atend i s)
|
|
nil
|
|
(iflet (endthis startnext) (next-parabreak s i)
|
|
(cons (cut s i endthis)
|
|
(paras s startnext))
|
|
(list (trim (cut s i) 'end)))))
|
|
|
|
|
|
; Returns the index of the first char not part of the url beginning
|
|
; at i, or len of string if url goes all the way to the end.
|
|
|
|
; Note that > immediately after a url (http://foo.com>) will cause
|
|
; an odd result, because the > gets escaped to something beginning
|
|
; with &, which is treated as part of the url. Perhaps the answer
|
|
; is just to esc-tags after markdown instead of before.
|
|
|
|
; Treats a delimiter as part of a url if it is (a) an open delimiter
|
|
; not followed by whitespace or eos, or (b) a close delimiter
|
|
; balancing a previous open delimiter.
|
|
|
|
(def urlend (s i (o indelim))
|
|
(let c (s i)
|
|
(if (atend i s)
|
|
(if ((orf punc whitec opendelim) c)
|
|
i
|
|
(closedelim c)
|
|
(if indelim (+ i 1) i)
|
|
(+ i 1))
|
|
(if (or (whitec c)
|
|
(and (punc c) (whitec (s (+ i 1))))
|
|
(and ((orf whitec punc) (s (+ i 1)))
|
|
(or (opendelim c)
|
|
(and (closedelim c) (no indelim)))))
|
|
i
|
|
(urlend s (+ i 1) (or (opendelim c)
|
|
(and indelim (no (closedelim c)))))))))
|
|
|
|
(def opendelim (c) (in c #\< #\( #\[ #\{))
|
|
|
|
(def closedelim (c) (in c #\> #\) #\] #\}))
|
|
|
|
|
|
(def code-block (s i)
|
|
(tostring
|
|
(until (let left (- (len s) i 1)
|
|
(or (is left 0)
|
|
(and (> left 2)
|
|
(is (s (+ i 1)) #\newline)
|
|
(nonwhite (s (+ i 2))))))
|
|
(writec (s (++ i))))))
|
|
|
|
(def unmarkdown (s)
|
|
(tostring
|
|
(forlen i s
|
|
(if (litmatch "<p>" s i)
|
|
(do (++ i 2)
|
|
(unless (is i 2) (pr "\n\n")))
|
|
(litmatch "<i>" s i)
|
|
(do (++ i 2) (pr #\*))
|
|
(litmatch "</i>" s i)
|
|
(do (++ i 3) (pr #\*))
|
|
(litmatch "<a href=" s i)
|
|
(let endurl (posmatch [in _ #\> #\space] s (+ i 9))
|
|
(if endurl
|
|
(do (pr (cut s (+ i 9) (- endurl 1)))
|
|
(= i (aif (posmatch "</a>" s endurl)
|
|
(+ it 3)
|
|
endurl)))
|
|
(writec (s i))))
|
|
(litmatch "<pre><code>" s i)
|
|
(awhen (findsubseq "</code></pre>" s (+ i 12))
|
|
(pr (cut s (+ i 11) it))
|
|
(= i (+ it 12)))
|
|
(writec (s i))))))
|
|
|
|
|
|
(def english-time (min)
|
|
(let n (mod min 720)
|
|
(string (let h (trunc (/ n 60)) (if (is h 0) "12" h))
|
|
":"
|
|
(let m (mod n 60)
|
|
(if (is m 0) "00"
|
|
(< m 10) (string "0" m)
|
|
m))
|
|
(if (is min 0) " midnight"
|
|
(is min 720) " noon"
|
|
(>= min 720) " pm"
|
|
" am"))))
|
|
|
|
(def parse-time (s)
|
|
(let (nums (o label "")) (halve s letter)
|
|
(with ((h (o m 0)) (map int (tokens nums ~digit))
|
|
cleanlabel (downcase (rem ~alphadig label)))
|
|
(+ (* (if (is h 12)
|
|
(if (in cleanlabel "am" "midnight")
|
|
0
|
|
12)
|
|
(is cleanlabel "am")
|
|
h
|
|
(+ h 12))
|
|
60)
|
|
m))))
|
|
|
|
|
|
(= months* '("January" "February" "March" "April" "May" "June" "July"
|
|
"August" "September" "October" "November" "December"))
|
|
|
|
(def english-date ((y m d))
|
|
(string d " " (months* (- m 1)) " " y))
|
|
|
|
(= month-names* (obj "january" 1 "jan" 1
|
|
"february" 2 "feb" 2
|
|
"march" 3 "mar" 3
|
|
"april" 4 "apr" 4
|
|
"may" 5
|
|
"june" 6 "jun" 6
|
|
"july" 7 "jul" 7
|
|
"august" 8 "aug" 8
|
|
"september" 9 "sept" 9 "sep" 9
|
|
"october" 10 "oct" 10
|
|
"november" 11 "nov" 11
|
|
"december" 12 "dec" 12))
|
|
|
|
(def monthnum (s) (month-names* (downcase s)))
|
|
|
|
; Doesn't work for BC dates.
|
|
|
|
(def parse-date (s)
|
|
(let nums (date-nums s)
|
|
(if (valid-date nums)
|
|
nums
|
|
(err (string "Invalid date: " s)))))
|
|
|
|
(def date-nums (s)
|
|
(with ((ynow mnow dnow) (date)
|
|
toks (tokens s ~alphadig))
|
|
(if (all [all digit _] toks)
|
|
(let nums (map int toks)
|
|
(case (len nums)
|
|
1 (list ynow mnow (car nums))
|
|
2 (iflet d (find [> _ 12] nums)
|
|
(list ynow (find [isnt _ d] nums) d)
|
|
(cons ynow nums))
|
|
(if (> (car nums) 31)
|
|
(firstn 3 nums)
|
|
(rev (firstn 3 nums)))))
|
|
([all digit _] (car toks))
|
|
(withs ((ds ms ys) toks
|
|
d (int ds))
|
|
(aif (monthnum ms)
|
|
(list (or (errsafe (int ys)) ynow)
|
|
it
|
|
d)
|
|
nil))
|
|
(monthnum (car toks))
|
|
(let (ms ds ys) toks
|
|
(aif (errsafe (int ds))
|
|
(list (or (errsafe (int ys)) ynow)
|
|
(monthnum (car toks))
|
|
it)
|
|
nil))
|
|
nil)))
|
|
|
|
; To be correct needs to know days per month, and about leap years
|
|
|
|
(def valid-date ((y m d))
|
|
(and y m d
|
|
(< 0 m 13)
|
|
(< 0 d 32)))
|
|
|
|
(mac defopl (name parm . body)
|
|
`(defop ,name ,parm
|
|
(if (get-user ,parm)
|
|
(do ,@body)
|
|
(login-page 'both
|
|
"You need to be logged in to do that."
|
|
(list (fn (u ip))
|
|
(string ',name (reassemble-args ,parm)))))))
|
|
|