hellerve/argos
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

initial

Browse Source
This commit is contained in:
Veit Heller
2018-05-14 00:08:25 +02:00
commit 3386ec0c4b
19 changed files with 7149 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
lib/README.md Normal file
View File

@@ -0,0 +1,5 @@
# lib
The Arc files from Arc3.1, obtainable [here](http://www.arclanguage.org/arc3.1.tar),
copied verbatim. See [copyright](./copyright) for the original copyright. I do
not own any of this, nor have I written any of it.

671
lib/app.arc Normal file
View File

@@ -0,0 +1,671 @@
; 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)))))))

1700
lib/arc.arc Normal file
View File

File diff suppressed because it is too large Load Diff

95
lib/blog.arc Normal file
View File

@@ -0,0 +1,95 @@
; Blog tool example. 20 Jan 08, rev 21 May 09.
; To run:
; arc> (load "blog.arc")
; arc> (bsv)
; go to http://localhost:8080/blog
(= postdir* "arc/posts/" maxid* 0 posts* (table))
(= blogtitle* "A Blog")
(deftem post id nil title nil text nil)
(def load-posts ()
(each id (map int (dir postdir*))
(= maxid* (max maxid* id)
(posts* id) (temload 'post (string postdir* id)))))
(def save-post (p) (save-table p (string postdir* p!id)))
(def post (id) (posts* (errsafe:int id)))
(mac blogpage body
`(whitepage
(center
(widtable 600
(tag b (link blogtitle* "blog"))
(br 3)
,@body
(br 3)
(w/bars (link "archive")
(link "new post" "newpost"))))))
(defop viewpost req (blogop post-page req))
(def blogop (f req)
(aif (post (arg req "id"))
(f (get-user req) it)
(blogpage (pr "No such post."))))
(def permalink (p) (string "viewpost?id=" p!id))
(def post-page (user p) (blogpage (display-post user p)))
(def display-post (user p)
(tag b (link p!title (permalink p)))
(when user
(sp)
(link "[edit]" (string "editpost?id=" p!id)))
(br2)
(pr p!text))
(defopl newpost req
(whitepage
(aform [let u (get-user _)
(post-page u (addpost u (arg _ "t") (arg _ "b")))]
(tab (row "title" (input "t" "" 60))
(row "text" (textarea "b" 10 80))
(row "" (submit))))))
(def addpost (user title text)
(let p (inst 'post 'id (++ maxid*) 'title title 'text text)
(save-post p)
(= (posts* p!id) p)))
(defopl editpost req (blogop edit-page req))
(def edit-page (user p)
(whitepage
(vars-form user
`((string title ,p!title t t) (text text ,p!text t t))
(fn (name val) (= (p name) val))
(fn () (save-post p)
(post-page user p)))))
(defop archive req
(blogpage
(tag ul
(each p (map post (rev (range 1 maxid*)))
(tag li (link p!title (permalink p)))))))
(defop blog req
(let user (get-user req)
(blogpage
(for i 0 4
(awhen (posts* (- maxid* i))
(display-post user it)
(br 3))))))
(def bsv ()
(ensure-dir postdir*)
(load-posts)
(asv))

61
lib/code.arc Normal file
View File

@@ -0,0 +1,61 @@
; Code analysis. Spun off 21 Dec 07.
; Ought to do more of this in Arc. One of the biggest advantages
; of Lisp is messing with code.
(def codelines (file)
(w/infile in file
(summing test
(whilet line (readline in)
(test (aand (find nonwhite line) (isnt it #\;)))))))
(def codeflat (file)
(len (flat (readall (infile file)))))
(def codetree (file)
(treewise + (fn (x) 1) (readall (infile file))))
(def code-density (file)
(/ (codetree file) (codelines file)))
(def tokcount (files)
(let counts (table)
(each f files
(each token (flat (readall (infile f)))
(++ (counts token 0))))
counts))
(def common-tokens (files)
(let counts (tokcount files)
(let ranking nil
(maptable (fn (k v)
(unless (nonop k)
(insort (compare > cadr) (list k v) ranking)))
counts)
ranking)))
(def nonop (x)
(in x 'quote 'unquote 'quasiquote 'unquote-splicing))
(def common-operators (files)
(keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))
(def top40 (xs)
(map prn (firstn 40 xs))
t)
(def space-eaters (files)
(let counts (tokcount files)
(let ranking nil
(maptable (fn (k v)
(when (and (isa k 'sym) (bound k))
(insort (compare > [* (len (string (car _)))
(cadr _)])
(list k v (* (len (string k)) v))
ranking)))
counts)
ranking)))
;(top40 (space-eaters allfiles*))
(mac flatlen args `(len (flat ',args)))

2
lib/copyright Normal file
View File

@@ -0,0 +1,2 @@
This software is copyright (c) Paul Graham and Robert Morris. Permission
to use it is granted under the Perl Foundations's Artistic License 2.0.

415
lib/html.arc Normal file
View File

@@ -0,0 +1,415 @@
; HTML Utils.
(def color (r g b)
(with (c (table)
f (fn (x) (if (< x 0) 0 (> x 255) 255 x)))
(= (c 'r) (f r) (c 'g) (f g) (c 'b) (f b))
c))
(def dehex (str) (errsafe (coerce str 'int 16)))
(defmemo hex>color (str)
(and (is (len str) 6)
(with (r (dehex (cut str 0 2))
g (dehex (cut str 2 4))
b (dehex (cut str 4 6)))
(and r g b
(color r g b)))))
(defmemo gray (n) (color n n n))
(= white (gray 255)
black (gray 0)
linkblue (color 0 0 190)
orange (color 255 102 0)
darkred (color 180 0 0)
darkblue (color 0 0 120)
)
(= opmeths* (table))
(mac opmeth args
`(opmeths* (list ,@args)))
(mac attribute (tag opt f)
`(= (opmeths* (list ',tag ',opt)) ,f))
(= hexreps (table))
(for i 0 255 (= (hexreps i)
(let s (coerce i 'string 16)
(if (is (len s) 1) (+ "0" s) s))))
(defmemo hexrep (col)
(+ (hexreps (col 'r)) (hexreps (col 'g)) (hexreps (col 'b))))
(def opcolor (key val)
(w/uniq gv
`(whenlet ,gv ,val
(pr ,(string " " key "=#") (hexrep ,gv)))))
(def opstring (key val)
`(aif ,val (pr ,(+ " " key "=\"") it #\")))
(def opnum (key val)
`(aif ,val (pr ,(+ " " key "=") it)))
(def opsym (key val)
`(pr ,(+ " " key "=") ,val))
(def opsel (key val)
`(if ,val (pr " selected")))
(def opcheck (key val)
`(if ,val (pr " checked")))
(def opesc (key val)
`(awhen ,val
(pr ,(string " " key "=\""))
(if (isa it 'string) (pr-escaped it) (pr it))
(pr #\")))
; need to escape more? =?
(def pr-escaped (x)
(each c x
(pr (case c #\< "&#60;"
#\> "&#62;"
#\" "&#34;"
#\& "&#38;"
c))))
(attribute a href opstring)
(attribute a rel opstring)
(attribute a class opstring)
(attribute a id opsym)
(attribute a onclick opstring)
(attribute body alink opcolor)
(attribute body bgcolor opcolor)
(attribute body leftmargin opnum)
(attribute body link opcolor)
(attribute body marginheight opnum)
(attribute body marginwidth opnum)
(attribute body topmargin opnum)
(attribute body vlink opcolor)
(attribute font color opcolor)
(attribute font face opstring)
(attribute font size opnum)
(attribute form action opstring)
(attribute form method opsym)
(attribute img align opsym)
(attribute img border opnum)
(attribute img height opnum)
(attribute img width opnum)
(attribute img vspace opnum)
(attribute img hspace opnum)
(attribute img src opstring)
(attribute input name opstring)
(attribute input size opnum)
(attribute input type opsym)
(attribute input value opesc)
(attribute input checked opcheck)
(attribute select name opstring)
(attribute option selected opsel)
(attribute table bgcolor opcolor)
(attribute table border opnum)
(attribute table cellpadding opnum)
(attribute table cellspacing opnum)
(attribute table width opstring)
(attribute textarea cols opnum)
(attribute textarea name opstring)
(attribute textarea rows opnum)
(attribute textarea wrap opsym)
(attribute td align opsym)
(attribute td bgcolor opcolor)
(attribute td colspan opnum)
(attribute td width opnum)
(attribute td valign opsym)
(attribute td class opstring)
(attribute tr bgcolor opcolor)
(attribute hr color opcolor)
(attribute span class opstring)
(attribute span align opstring)
(attribute span id opsym)
(attribute rss version opstring)
(mac gentag args (start-tag args))
(mac tag (spec . body)
`(do ,(start-tag spec)
,@body
,(end-tag spec)))
(mac tag-if (test spec . body)
`(if ,test
(tag ,spec ,@body)
(do ,@body)))
(def start-tag (spec)
(if (atom spec)
`(pr ,(string "<" spec ">"))
(let opts (tag-options (car spec) (pair (cdr spec)))
(if (all [isa _ 'string] opts)
`(pr ,(string "<" (car spec) (apply string opts) ">"))
`(do (pr ,(string "<" (car spec)))
,@(map (fn (opt)
(if (isa opt 'string)
`(pr ,opt)
opt))
opts)
(pr ">"))))))
(def end-tag (spec)
`(pr ,(string "</" (carif spec) ">")))
(def literal (x)
(case (type x)
sym (in x nil t)
cons (caris x 'quote)
t))
; Returns a list whose elements are either strings, which can
; simply be printed out, or expressions, which when evaluated
; generate output.
(def tag-options (spec options)
(if (no options)
'()
(let ((opt val) . rest) options
(let meth (if (is opt 'style) opstring (opmeth spec opt))
(if meth
(if val
(cons (if (precomputable-tagopt val)
(tostring (eval (meth opt val)))
(meth opt val))
(tag-options spec rest))
(tag-options spec rest))
(do
(pr "<!-- ignoring " opt " for " spec "-->")
(tag-options spec rest)))))))
(def precomputable-tagopt (val)
(and (literal val)
(no (and (is (type val) 'string) (find #\@ val)))))
(def br ((o n 1))
(repeat n (pr "<br>"))
(prn))
(def br2 () (prn "<br><br>"))
(mac center body `(tag center ,@body))
(mac underline body `(tag u ,@body))
(mac tab body `(tag (table border 0) ,@body))
(mac tr body `(tag tr ,@body))
(let pratoms (fn (body)
(if (or (no body)
(all [and (acons _) (isnt (car _) 'quote)]
body))
body
`((pr ,@body))))
(mac td body `(tag td ,@(pratoms body)))
(mac trtd body `(tr (td ,@(pratoms body))))
(mac tdr body `(tag (td align 'right) ,@(pratoms body)))
(mac tdcolor (col . body) `(tag (td bgcolor ,col) ,@(pratoms body)))
)
(mac row args
`(tr ,@(map [list 'td _] args)))
(mac prrow args
(w/uniq g
`(tr ,@(map (fn (a)
`(let ,g ,a
(if (number ,g)
(tdr (pr ,g))
(td (pr ,g)))))
args))))
(mac prbold body `(tag b (pr ,@body)))
(def para args
(gentag p)
(when args (apply pr args)))
(def menu (name items (o sel nil))
(tag (select name name)
(each i items
(tag (option selected (is i sel))
(pr i)))))
(mac whitepage body
`(tag html
(tag (body bgcolor white alink linkblue) ,@body)))
(def errpage args (whitepage (apply prn args)))
(def blank-url () "s.gif")
; Could memoize these.
; If h = 0, doesn't affect table column widths in some Netscapes.
(def hspace (n) (gentag img src (blank-url) height 1 width n))
(def vspace (n) (gentag img src (blank-url) height n width 0))
(def vhspace (h w) (gentag img src (blank-url) height h width w))
(mac new-hspace (n)
(if (number n)
`(pr ,(string "<span style=\"padding-left:" n "px\" />"))
`(pr "<span style=\"padding-left:" ,n "px\" />")))
;(def spacerow (h) (tr (td (vspace h))))
(def spacerow (h) (pr "<tr style=\"height:" h "px\"></tr>"))
; For use as nested table.
(mac zerotable body
`(tag (table border 0 cellpadding 0 cellspacing 0)
,@body))
; was `(tag (table border 0 cellpadding 0 cellspacing 7) ,@body)
(mac sptab body
`(tag (table style "border-spacing: 7px 0px;") ,@body))
(mac widtable (w . body)
`(tag (table width ,w) (tr (td ,@body))))
(def cellpr (x) (pr (or x "&nbsp;")))
(def but ((o text "submit") (o name nil))
(gentag input type 'submit name name value text))
(def submit ((o val "submit"))
(gentag input type 'submit value val))
(def buts (name . texts)
(if (no texts)
(but)
(do (but (car texts) name)
(each text (cdr texts)
(pr " ")
(but text name)))))
(mac spanrow (n . body)
`(tr (tag (td colspan ,n) ,@body)))
(mac form (action . body)
`(tag (form method "post" action ,action) ,@body))
(mac textarea (name rows cols . body)
`(tag (textarea name ,name rows ,rows cols ,cols) ,@body))
(def input (name (o val "") (o size 10))
(gentag input type 'text name name value val size size))
(mac inputs args
`(tag (table border 0)
,@(map (fn ((name label len text))
(w/uniq (gl gt)
`(let ,gl ,len
(tr (td (pr ',label ":"))
(if (isa ,gl 'cons)
(td (textarea ',name (car ,gl) (cadr ,gl)
(let ,gt ,text (if ,gt (pr ,gt)))))
(td (gentag input type ',(if (is label 'password)
'password
'text)
name ',name
size ,len
value ,text)))))))
(tuples args 4))))
(def single-input (label name chars btext (o pwd))
(pr label)
(gentag input type (if pwd 'password 'text) name name size chars)
(sp)
(submit btext))
(mac cdata body
`(do (pr "<![CDATA[")
,@body
(pr "]]>")))
(def eschtml (str)
(tostring
(each c str
(pr (case c #\< "&#60;"
#\> "&#62;"
#\" "&#34;"
#\' "&#39;"
#\& "&#38;"
c)))))
(def esc-tags (str)
(tostring
(each c str
(pr (case c #\< "&#60;"
#\> "&#62;"
#\& "&#38;"
c)))))
(def nbsp () (pr "&nbsp;"))
(def link (text (o dest text) (o color))
(tag (a href dest)
(tag-if color (font color color)
(pr text))))
(def underlink (text (o dest text))
(tag (a href dest) (tag u (pr text))))
(def striptags (s)
(let intag nil
(tostring
(each c s
(if (is c #\<) (set intag)
(is c #\>) (wipe intag)
(no intag) (pr c))))))
(def clean-url (u)
(rem [in _ #\" #\' #\< #\>] u))
(def shortlink (url)
(unless (or (no url) (< (len url) 7))
(link (cut url 7) url)))
; this should be one regexp
(def parafy (str)
(let ink nil
(tostring
(each c str
(pr c)
(unless (whitec c) (set ink))
(when (is c #\newline)
(unless ink (pr "<p>"))
(wipe ink))))))
(mac spanclass (name . body)
`(tag (span class ',name) ,@body))
(def pagemessage (text)
(when text (prn text) (br2)))
; Could be stricter. Memoized because looking for chars in Unicode
; strings is terribly inefficient in Mzscheme.
(defmemo valid-url (url)
(and (len> url 10)
(or (begins url "http://")
(begins url "https://"))
(~find [in _ #\< #\> #\" #\'] url)))
(mac fontcolor (c . body)
(w/uniq g
`(let ,g ,c
(if ,g
(tag (font color ,g) ,@body)
(do ,@body)))))

7
lib/libs.arc Normal file
View File

@@ -0,0 +1,7 @@
(map load '("strings.arc"
"pprint.arc"
"code.arc"
"html.arc"
"srv.arc"
"app.arc"
"prompt.arc"))

2617
lib/news.arc Normal file
View File

File diff suppressed because it is too large Load Diff

80
lib/pprint.arc Normal file
View File

@@ -0,0 +1,80 @@
; Pretty-Printing. Spun off 4 Aug 06.
; todo: indentation of long ifs; quasiquote, unquote, unquote-splicing
(= bodops* (fill-table (table)
'(let 2 with 1 while 1 def 2 fn 1 rfn 2 afn 1
when 1 unless 1 after 1 whilet 2 for 3 each 2 whenlet 2 awhen 1
whitepage 0 tag 1 form 1 aform 1 aformh 1 w/link 1 textarea 3
)))
(= oneline* 35) ; print exprs less than this long on one line
; If returns nil, can assume it didn't have to break expr.
(def ppr (expr (o col 0) (o noindent nil))
(if (or (atom expr) (dotted expr))
(do (unless noindent (sp col))
(write expr)
nil)
(is (car expr) 'quote)
(do (unless noindent (sp col))
(pr "'")
(ppr (cadr expr) (+ col 1) t))
(bodops* (car expr))
(do (unless noindent (sp col))
(let whole (tostring (write expr))
(if (< (len whole) oneline*)
(do (pr whole) nil)
(ppr-progn expr col noindent))))
(do (unless noindent (sp col))
(let whole (tostring (write expr))
(if (< (len whole) oneline*)
(do (pr whole) nil)
(ppr-call expr col noindent))))))
(def ppr-progn (expr col noindent)
(lpar)
(let n (bodops* (car expr))
(let str (tostring (write-spaced (firstn n expr)))
(unless (is n 0) (pr str) (sp))
(ppr (expr n) (+ col (len str) 2) t))
(map (fn (e) (prn) (ppr e (+ col 2)))
(nthcdr (+ n 1) expr)))
(rpar)
t)
(def ppr-call (expr col noindent)
(lpar)
(let carstr (tostring (write (car expr)))
(pr carstr)
(if (cdr expr)
(do (sp)
(let broke (ppr (cadr expr) (+ col (len carstr) 2) t)
(pprest (cddr expr)
(+ col (len carstr) 2)
(no broke)))
t)
(do (rpar) t))))
(def pprest (exprs col (o oneline t))
(if (and oneline
(all (fn (e)
(or (atom e) (and (is (car e) 'quote) (atom (cadr e)))))
exprs))
(do (map (fn (e) (pr " ") (write e))
exprs)
(rpar))
(do (when exprs
(each e exprs (prn) (ppr e col)))
(rpar))))
(def write-spaced (xs)
(when xs
(write (car xs))
(each x (cdr xs) (pr " ") (write x))))
(def sp ((o n 1)) (repeat n (pr " ")))
(def lpar () (pr "("))
(def rpar () (pr ")"))

119
lib/prompt.arc Normal file
View File

@@ -0,0 +1,119 @@
; Prompt: Web-based programming application. 4 Aug 06.
(= appdir* "arc/apps/")
(defop prompt req
(let user (get-user req)
(if (admin user)
(prompt-page user)
(pr "Sorry."))))
(def prompt-page (user . msg)
(ensure-dir appdir*)
(ensure-dir (string appdir* user))
(whitepage
(prbold "Prompt")
(hspace 20)
(pr user " | ")
(link "logout")
(when msg (hspace 10) (apply pr msg))
(br2)
(tag (table border 0 cellspacing 10)
(each app (dir (+ appdir* user))
(tr (td app)
(td (ulink user 'edit (edit-app user app)))
(td (ulink user 'run (run-app user app)))
(td (hspace 40)
(ulink user 'delete (rem-app user app))))))
(br2)
(aform (fn (req)
(when-umatch user req
(aif (goodname (arg req "app"))
(edit-app user it)
(prompt-page user "Bad name."))))
(tab (row "name:" (input "app") (submit "create app"))))))
(def app-path (user app)
(and user app (+ appdir* user "/" app)))
(def read-app (user app)
(aand (app-path user app)
(file-exists it)
(readfile it)))
(def write-app (user app exprs)
(awhen (app-path user app)
(w/outfile o it
(each e exprs (write e o)))))
(def rem-app (user app)
(let file (app-path user app)
(if (file-exists file)
(do (rmfile (app-path user app))
(prompt-page user "Program " app " deleted."))
(prompt-page user "No such app."))))
(def edit-app (user app)
(whitepage
(pr "user: " user " app: " app)
(br2)
(aform (fn (req)
(let u2 (get-user req)
(if (is u2 user)
(do (when (is (arg req "cmd") "save")
(write-app user app (readall (arg req "exprs"))))
(prompt-page user))
(login-page 'both nil
(fn (u ip) (prompt-page u))))))
(textarea "exprs" 10 82
(pprcode (read-app user app)))
(br2)
(buts 'cmd "save" "cancel"))))
(def pprcode (exprs)
(each e exprs
(ppr e)
(pr "\n\n")))
(def view-app (user app)
(whitepage
(pr "user: " user " app: " app)
(br2)
(tag xmp (pprcode (read-app user app)))))
(def run-app (user app)
(let exprs (read-app user app)
(if exprs
(on-err (fn (c) (pr "Error: " (details c)))
(fn () (map eval exprs)))
(prompt-page user "Error: No application " app " for user " user))))
(wipe repl-history*)
(defop repl req
(if (admin (get-user req))
(replpage req)
(pr "Sorry.")))
(def replpage (req)
(whitepage
(repl (readall (or (arg req "expr") "")) "repl")))
(def repl (exprs url)
(each expr exprs
(on-err (fn (c) (push (list expr c t) repl-history*))
(fn ()
(= that (eval expr) thatexpr expr)
(push (list expr that) repl-history*))))
(form url
(textarea "expr" 8 60)
(sp)
(submit))
(tag xmp
(each (expr val err) (firstn 20 repl-history*)
(pr "> ")
(ppr expr)
(prn)
(prn (if err "Error: " "")
(ellipsize (tostring (write val)) 800)))))

573
lib/srv.arc Normal file
View File

@@ -0,0 +1,573 @@
; HTTP Server.
; To improve performance with static files, set static-max-age*.
(= arcdir* "arc/" logdir* "arc/logs/" staticdir* "static/")
(= quitsrv* nil breaksrv* nil)
(def serve ((o port 8080))
(wipe quitsrv*)
(ensure-srvdirs)
(map [apply new-bgthread _] pending-bgthreads*)
(w/socket s port
(setuid 2) ; XXX switch from root to pg
(prn "ready to serve port " port)
(flushout)
(= currsock* s)
(until quitsrv*
(handle-request s breaksrv*)))
(prn "quit server"))
(def serve1 ((o port 8080))
(w/socket s port (handle-request s t)))
(def ensure-srvdirs ()
(map ensure-dir (list arcdir* logdir* staticdir*)))
(= srv-noisy* nil)
; http requests currently capped at 2 meg by socket-accept
; should threads process requests one at a time? no, then
; a browser that's slow consuming the data could hang the
; whole server.
; wait for a connection from a browser and start a thread
; to handle it. also arrange to kill that thread if it
; has not completed in threadlife* seconds.
(= threadlife* 30 requests* 0 requests/ip* (table)
throttle-ips* (table) ignore-ips* (table) spurned* (table))
(def handle-request (s breaksrv)
(if breaksrv
(handle-request-1 s)
(errsafe (handle-request-1 s))))
(def handle-request-1 (s)
(let (i o ip) (socket-accept s)
(if (and (or (ignore-ips* ip) (abusive-ip ip))
(++ (spurned* ip 0)))
(force-close i o)
(do (++ requests*)
(++ (requests/ip* ip 0))
(with (th1 nil th2 nil)
(= th1 (thread
(after (handle-request-thread i o ip)
(close i o)
(kill-thread th2))))
(= th2 (thread
(sleep threadlife*)
(unless (dead th1)
(prn "srv thread took too long for " ip))
(break-thread th1)
(force-close i o))))))))
; Returns true if ip has made req-limit* requests in less than
; req-window* seconds. If an ip is throttled, only 1 request is
; allowed per req-window* seconds. If an ip makes req-limit*
; requests in less than dos-window* seconds, it is a treated as a DoS
; attack and put in ignore-ips* (for this server invocation).
; To adjust this while running, adjust the req-window* time, not
; req-limit*, because algorithm doesn't enforce decreases in the latter.
(= req-times* (table) req-limit* 30 req-window* 10 dos-window* 2)
(def abusive-ip (ip)
(and (only.> (requests/ip* ip) 250)
(let now (seconds)
(do1 (if (req-times* ip)
(and (>= (qlen (req-times* ip))
(if (throttle-ips* ip) 1 req-limit*))
(let dt (- now (deq (req-times* ip)))
(if (< dt dos-window*) (set (ignore-ips* ip)))
(< dt req-window*)))
(do (= (req-times* ip) (queue))
nil))
(enq now (req-times* ip))))))
(def handle-request-thread (i o ip)
(with (nls 0 lines nil line nil responded nil t0 (msec))
(after
(whilet c (unless responded (readc i))
(if srv-noisy* (pr c))
(if (is c #\newline)
(if (is (++ nls) 2)
(let (type op args n cooks) (parseheader (rev lines))
(let t1 (msec)
(case type
get (respond o op args cooks ip)
post (handle-post i o op args n cooks ip)
(respond-err o "Unknown request: " (car lines)))
(log-request type op args cooks ip t0 t1)
(set responded)))
(do (push (string (rev line)) lines)
(wipe line)))
(unless (is c #\return)
(push c line)
(= nls 0))))
(close i o)))
(harvest-fnids))
(def log-request (type op args cooks ip t0 t1)
(with (parsetime (- t1 t0) respondtime (- (msec) t1))
(srvlog 'srv ip
parsetime
respondtime
(if (> (+ parsetime respondtime) 1000) "***" "")
type
op
(let arg1 (car args)
(if (caris arg1 "fnid") "" arg1))
cooks)))
; Could ignore return chars (which come from textarea fields) here by
; (unless (is c #\return) (push c line))
(def handle-post (i o op args n cooks ip)
(if srv-noisy* (pr "Post Contents: "))
(if (no n)
(respond-err o "Post request without Content-Length.")
(let line nil
(whilet c (and (> n 0) (readc i))
(if srv-noisy* (pr c))
(-- n)
(push c line))
(if srv-noisy* (pr "\n\n"))
(respond o op (+ (parseargs (string (rev line))) args) cooks ip))))
(= header* "HTTP/1.1 200 OK
Content-Type: text/html; charset=utf-8
Connection: close")
(= type-header* (table))
(def gen-type-header (ctype)
(+ "HTTP/1.0 200 OK
Content-Type: "
ctype
"
Connection: close"))
(map (fn ((k v)) (= (type-header* k) (gen-type-header v)))
'((gif "image/gif")
(jpg "image/jpeg")
(png "image/png")
(text/html "text/html; charset=utf-8")))
(= rdheader* "HTTP/1.0 302 Moved")
(= srvops* (table) redirector* (table) optimes* (table) opcounts* (table))
(def save-optime (name elapsed)
; this is the place to put a/b testing
; toggle a flag and push elapsed into one of two lists
(++ (opcounts* name 0))
(unless (optimes* name) (= (optimes* name) (queue)))
(enq-limit elapsed (optimes* name) 1000))
; For ops that want to add their own headers. They must thus remember
; to prn a blank line before anything meant to be part of the page.
(mac defop-raw (name parms . body)
(w/uniq t1
`(= (srvops* ',name)
(fn ,parms
(let ,t1 (msec)
(do1 (do ,@body)
(save-optime ',name (- (msec) ,t1))))))))
(mac defopr-raw (name parms . body)
`(= (redirector* ',name) t
(srvops* ',name) (fn ,parms ,@body)))
(mac defop (name parm . body)
(w/uniq gs
`(do (wipe (redirector* ',name))
(defop-raw ,name (,gs ,parm)
(w/stdout ,gs (prn) ,@body)))))
; Defines op as a redirector. Its retval is new location.
(mac defopr (name parm . body)
(w/uniq gs
`(do (set (redirector* ',name))
(defop-raw ,name (,gs ,parm)
,@body))))
;(mac testop (name . args) `((srvops* ',name) ,@args))
(deftem request
args nil
cooks nil
ip nil)
(= unknown-msg* "Unknown." max-age* (table) static-max-age* nil)
(def respond (str op args cooks ip)
(w/stdout str
(iflet f (srvops* op)
(let req (inst 'request 'args args 'cooks cooks 'ip ip)
(if (redirector* op)
(do (prn rdheader*)
(prn "Location: " (f str req))
(prn))
(do (prn header*)
(awhen (max-age* op)
(prn "Cache-Control: max-age=" it))
(f str req))))
(let filetype (static-filetype op)
(aif (and filetype (file-exists (string staticdir* op)))
(do (prn (type-header* filetype))
(awhen static-max-age*
(prn "Cache-Control: max-age=" it))
(prn)
(w/infile i it
(whilet b (readb i)
(writeb b str))))
(respond-err str unknown-msg*))))))
(def static-filetype (sym)
(let fname (coerce sym 'string)
(and (~find #\/ fname)
(case (downcase (last (check (tokens fname #\.) ~single)))
"gif" 'gif
"jpg" 'jpg
"jpeg" 'jpg
"png" 'png
"css" 'text/html
"txt" 'text/html
"htm" 'text/html
"html" 'text/html
"arc" 'text/html
))))
(def respond-err (str msg . args)
(w/stdout str
(prn header*)
(prn)
(apply pr msg args)))
(def parseheader (lines)
(let (type op args) (parseurl (car lines))
(list type
op
args
(and (is type 'post)
(some (fn (s)
(and (begins s "Content-Length:")
(errsafe:coerce (cadr (tokens s)) 'int)))
(cdr lines)))
(some (fn (s)
(and (begins s "Cookie:")
(parsecookies s)))
(cdr lines)))))
; (parseurl "GET /p1?foo=bar&ug etc") -> (get p1 (("foo" "bar") ("ug")))
(def parseurl (s)
(let (type url) (tokens s)
(let (base args) (tokens url #\?)
(list (sym (downcase type))
(sym (cut base 1))
(if args
(parseargs args)
nil)))))
; I don't urldecode field names or anything in cookies; correct?
(def parseargs (s)
(map (fn ((k v)) (list k (urldecode v)))
(map [tokens _ #\=] (tokens s #\&))))
(def parsecookies (s)
(map [tokens _ #\=]
(cdr (tokens s [or (whitec _) (is _ #\;)]))))
(def arg (req key) (alref req!args key))
; *** Warning: does not currently urlencode args, so if need to do
; that replace v with (urlencode v).
(def reassemble-args (req)
(aif req!args
(apply string "?" (intersperse '&
(map (fn ((k v))
(string k '= v))
it)))
""))
(= fns* (table) fnids* nil timed-fnids* nil)
; count on huge (expt 64 10) size of fnid space to avoid clashes
(def new-fnid ()
(check (sym (rand-string 10)) ~fns* (new-fnid)))
(def fnid (f)
(atlet key (new-fnid)
(= (fns* key) f)
(push key fnids*)
key))
(def timed-fnid (lasts f)
(atlet key (new-fnid)
(= (fns* key) f)
(push (list key (seconds) lasts) timed-fnids*)
key))
; Within f, it will be bound to the fn's own fnid. Remember that this is
; so low-level that need to generate the newline to separate from the headers
; within the body of f.
(mac afnid (f)
`(atlet it (new-fnid)
(= (fns* it) ,f)
(push it fnids*)
it))
;(defop test-afnid req
; (tag (a href (url-for (afnid (fn (req) (prn) (pr "my fnid is " it)))))
; (pr "click here")))
; To be more sophisticated, instead of killing fnids, could first
; replace them with fns that tell the server it's harvesting too
; aggressively if they start to get called. But the right thing to
; do is estimate what the max no of fnids can be and set the harvest
; limit there-- beyond that the only solution is to buy more memory.
(def harvest-fnids ((o n 50000)) ; was 20000
(when (len> fns* n)
(pull (fn ((id created lasts))
(when (> (since created) lasts)
(wipe (fns* id))
t))
timed-fnids*)
(atlet nharvest (trunc (/ n 10))
(let (kill keep) (split (rev fnids*) nharvest)
(= fnids* (rev keep))
(each id kill
(wipe (fns* id)))))))
(= fnurl* "/x" rfnurl* "/r" rfnurl2* "/y" jfnurl* "/a")
(= dead-msg* "\nUnknown or expired link.")
(defop-raw x (str req)
(w/stdout str
(aif (fns* (sym (arg req "fnid")))
(it req)
(pr dead-msg*))))
(defopr-raw y (str req)
(aif (fns* (sym (arg req "fnid")))
(w/stdout str (it req))
"deadlink"))
; For asynchronous calls; discards the page. Would be better to tell
; the fn not to generate it.
(defop-raw a (str req)
(aif (fns* (sym (arg req "fnid")))
(tostring (it req))))
(defopr r req
(aif (fns* (sym (arg req "fnid")))
(it req)
"deadlink"))
(defop deadlink req
(pr dead-msg*))
(def url-for (fnid)
(string fnurl* "?fnid=" fnid))
(def flink (f)
(string fnurl* "?fnid=" (fnid (fn (req) (prn) (f req)))))
(def rflink (f)
(string rfnurl* "?fnid=" (fnid f)))
; Since it's just an expr, gensym a parm for (ignored) args.
(mac w/link (expr . body)
`(tag (a href (flink (fn (,(uniq)) ,expr)))
,@body))
(mac w/rlink (expr . body)
`(tag (a href (rflink (fn (,(uniq)) ,expr)))
,@body))
(mac onlink (text . body)
`(w/link (do ,@body) (pr ,text)))
(mac onrlink (text . body)
`(w/rlink (do ,@body) (pr ,text)))
; bad to have both flink and linkf; rename flink something like fnid-link
(mac linkf (text parms . body)
`(tag (a href (flink (fn ,parms ,@body))) (pr ,text)))
(mac rlinkf (text parms . body)
`(tag (a href (rflink (fn ,parms ,@body))) (pr ,text)))
;(defop top req (linkf 'whoami? (req) (pr "I am " (get-user req))))
;(defop testf req (w/link (pr "ha ha ha") (pr "laugh")))
(mac w/link-if (test expr . body)
`(tag-if ,test (a href (flink (fn (,(uniq)) ,expr)))
,@body))
(def fnid-field (id)
(gentag input type 'hidden name 'fnid value id))
; f should be a fn of one arg, which will be http request args.
(def fnform (f bodyfn (o redir))
(tag (form method 'post action (if redir rfnurl2* fnurl*))
(fnid-field (fnid f))
(bodyfn)))
; Could also make a version that uses just an expr, and var capture.
; Is there a way to ensure user doesn't use "fnid" as a key?
(mac aform (f . body)
(w/uniq ga
`(tag (form method 'post action fnurl*)
(fnid-field (fnid (fn (,ga)
(prn)
(,f ,ga))))
,@body)))
;(defop test1 req
; (fnform (fn (req) (prn) (pr req))
; (fn () (single-input "" 'foo 20 "submit"))))
;(defop test2 req
; (aform (fn (req) (pr req))
; (single-input "" 'foo 20 "submit")))
; Like aform except creates a fnid that will last for lasts seconds
; (unless the server is restarted).
(mac taform (lasts f . body)
(w/uniq (gl gf gi ga)
`(withs (,gl ,lasts
,gf (fn (,ga) (prn) (,f ,ga)))
(tag (form method 'post action fnurl*)
(fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
,@body))))
(mac arform (f . body)
`(tag (form method 'post action rfnurl*)
(fnid-field (fnid ,f))
,@body))
; overlong
(mac tarform (lasts f . body)
(w/uniq (gl gf)
`(withs (,gl ,lasts ,gf ,f)
(tag (form method 'post action rfnurl*)
(fnid-field (if ,gl (timed-fnid ,gl ,gf) (fnid ,gf)))
,@body))))
(mac aformh (f . body)
`(tag (form method 'post action fnurl*)
(fnid-field (fnid ,f))
,@body))
(mac arformh (f . body)
`(tag (form method 'post action rfnurl2*)
(fnid-field (fnid ,f))
,@body))
; only unique per server invocation
(= unique-ids* (table))
(def unique-id ((o len 8))
(let id (sym (rand-string (max 5 len)))
(if (unique-ids* id)
(unique-id)
(= (unique-ids* id) id))))
(def srvlog (type . args)
(w/appendfile o (logfile-name type)
(w/stdout o (atomic (apply prs (seconds) args) (prn)))))
(def logfile-name (type)
(string logdir* type "-" (memodate)))
(with (lastasked nil lastval nil)
(def memodate ()
(let now (seconds)
(if (or (no lastasked) (> (- now lastasked) 60))
(= lastasked now lastval (datestring))
lastval)))
)
(defop || req (pr "It's alive."))
(defop topips req
(when (admin (get-user req))
(whitepage
(sptab
(each ip (let leaders nil
(maptable (fn (ip n)
(when (> n 100)
(insort (compare > requests/ip*)
ip
leaders)))
requests/ip*)
leaders)
(let n (requests/ip* ip)
(row ip n (pr (num (* 100 (/ n requests*)) 1)))))))))
(defop spurned req
(when (admin (get-user req))
(whitepage
(sptab
(map (fn ((ip n)) (row ip n))
(sortable spurned*))))))
; eventually promote to general util
(def sortable (ht (o f >))
(let res nil
(maptable (fn kv
(insort (compare f cadr) kv res))
ht)
res))
; Background Threads
(= bgthreads* (table) pending-bgthreads* nil)
(def new-bgthread (id f sec)
(aif (bgthreads* id) (break-thread it))
(= (bgthreads* id) (new-thread (fn ()
(while t
(sleep sec)
(f))))))
; should be a macro for this?
(mac defbg (id sec . body)
`(do (pull [caris _ ',id] pending-bgthreads*)
(push (list ',id (fn () ,@body) ,sec)
pending-bgthreads*)))
; Idea: make form fields that know their value type because of
; gensymed names, and so the receiving fn gets args that are not
; strings but parsed values.

226
lib/strings.arc Normal file
View File

@@ -0,0 +1,226 @@
; Matching. Spun off 29 Jul 06.
; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"
(def tokens (s (o sep whitec))
(let test (testify sep)
(let rec (afn (cs toks tok)
(if (no cs) (consif tok toks)
(test (car cs)) (self (cdr cs) (consif tok toks) nil)
(self (cdr cs) toks (cons (car cs) tok))))
(rev (map [coerce _ 'string]
(map rev (rec (coerce s 'cons) nil nil)))))))
; names of cut, split, halve not optimal
(def halve (s (o sep whitec))
(let test (testify sep)
(let rec (afn (cs tok)
(if (no cs) (list (rev tok))
(test (car cs)) (list cs (rev tok))
(self (cdr cs) (cons (car cs) tok))))
(rev (map [coerce _ 'string]
(rec (coerce s 'cons) nil))))))
; maybe promote to arc.arc, but if so include a list clause
(def positions (test seq)
(accum a
(let f (testify test)
(forlen i seq
(if (f (seq i)) (a i))))))
(def lines (s)
(accum a
((afn ((p . ps))
(if ps
(do (a (rem #\return (cut s (+ p 1) (car ps))))
(self ps))
(a (cut s (+ p 1)))))
(cons -1 (positions #\newline s)))))
(def slices (s test)
(accum a
((afn ((p . ps))
(if ps
(do (a (cut s (+ p 1) (car ps)))
(self ps))
(a (cut s (+ p 1)))))
(cons -1 (positions test s)))))
; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"
; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.
; Fixed for utf8 by pc.
(def urldecode (s)
(tostring
(forlen i s
(caselet c (s i)
#\+ (writec #\space)
#\% (do (when (> (- (len s) i) 2)
(writeb (int (cut s (+ i 1) (+ i 3)) 16)))
(++ i 2))
(writec c)))))
(def urlencode (s)
(tostring
(each c s
(writec #\%)
(let i (int c)
(if (< i 16) (writec #\0))
(pr (coerce i 'string 16))))))
(mac litmatch (pat string (o start 0))
(w/uniq (gstring gstart)
`(with (,gstring ,string ,gstart ,start)
(unless (> (+ ,gstart ,(len pat)) (len ,gstring))
(and ,@(let acc nil
(forlen i pat
(push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
acc))
(rev acc)))))))
; litmatch would be cleaner if map worked for string and integer args:
; ,@(map (fn (n c)
; `(is ,c (,gstring (+ ,gstart ,n))))
; (len pat)
; pat)
(mac endmatch (pat string)
(w/uniq (gstring glen)
`(withs (,gstring ,string ,glen (len ,gstring))
(unless (> ,(len pat) (len ,gstring))
(and ,@(let acc nil
(forlen i pat
(push `(is ,(pat (- (len pat) 1 i))
(,gstring (- ,glen 1 ,i)))
acc))
(rev acc)))))))
(def posmatch (pat seq (o start 0))
(catch
(if (isa pat 'fn)
(for i start (- (len seq) 1)
(when (pat (seq i)) (throw i)))
(for i start (- (len seq) (len pat))
(when (headmatch pat seq i) (throw i))))
nil))
(def headmatch (pat seq (o start 0))
(let p (len pat)
((afn (i)
(or (is i p)
(and (is (pat i) (seq (+ i start)))
(self (+ i 1)))))
0)))
(def begins (seq pat (o start 0))
(unless (len> pat (- (len seq) start))
(headmatch pat seq start)))
(def subst (new old seq)
(let boundary (+ (- (len seq) (len old)) 1)
(tostring
(forlen i seq
(if (and (< i boundary) (headmatch old seq i))
(do (++ i (- (len old) 1))
(pr new))
(pr (seq i)))))))
(def multisubst (pairs seq)
(tostring
(forlen i seq
(iflet (old new) (find [begins seq (car _) i] pairs)
(do (++ i (- (len old) 1))
(pr new))
(pr (seq i))))))
; not a good name
(def findsubseq (pat seq (o start 0))
(if (< (- (len seq) start) (len pat))
nil
(if (headmatch pat seq start)
start
(findsubseq pat seq (+ start 1)))))
(def blank (s) (~find ~whitec s))
(def nonblank (s) (unless (blank s) s))
(def trim (s (o where 'both) (o test whitec))
(withs (f (testify test)
p1 (pos ~f s))
(if p1
(cut s
(if (in where 'front 'both) p1 0)
(when (in where 'end 'both)
(let i (- (len s) 1)
(while (and (> i p1) (f (s i)))
(-- i))
(+ i 1))))
"")))
(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
(withs (comma
(fn (i)
(tostring
(map [apply pr (rev _)]
(rev (intersperse '(#\,)
(tuples (rev (coerce (string i) 'cons))
3))))))
abrep
(let a (abs n)
(if (< digits 1)
(comma (roundup a))
(exact a)
(string (comma a)
(when (and trail-zeros (> digits 0))
(string "." (newstring digits #\0))))
(withs (d (expt 10 digits)
m (/ (roundup (* a d)) d)
i (trunc m)
r (abs (trunc (- (* m d) (* i d)))))
(+ (if (is i 0)
(if (or init-zero (is r 0)) "0" "")
(comma i))
(withs (rest (string r)
padded (+ (newstring (- digits (len rest)) #\0)
rest)
final (if trail-zeros
padded
(trim padded 'end [is _ #\0])))
(string (unless (empty final) ".")
final)))))))
(if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
(+ "-" abrep)
abrep)))
; English
(def pluralize (n str)
(if (or (is n 1) (single n))
str
(string str "s")))
(def plural (n x)
(string n #\ (pluralize n x)))
; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html