commit 5ee05dfac2bf2ecb0cfadea21aed30466b26afb6
parent 5bb26243ba77f51a03a29d301bd6078494b62d4f
Author: tomas <tomas@logand.com>
Date: Thu, 29 Jul 2010 20:52:56 +0200
leaving cgi based wiki
Diffstat:
| M | init.l | | | 4 | +++- |
| M | main.l | | | 6 | +++--- |
| M | picowiki.l | | | 745 | ++++++++++++++++++++++++++++++++++--------------------------------------------- |
| A | rcs.l | | | 14 | ++++++++++++++ |
| A | rss.l | | | 99 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
5 files changed, 436 insertions(+), 432 deletions(-)
diff --git a/init.l b/init.l
@@ -1,3 +1,5 @@
(let D "init/"
(for F (dir D)
- (blob! (new! '(+Pg) 'nm F) 'txt (pack D F)) ) )
+ (let? Pg (new! '(+Pg) 'nm F)
+ (blob! Pg 'txt (pack D F))
+ (rcsIn (blob Pg 'txt) "Created" F) ) ) )
diff --git a/main.l b/main.l
@@ -1,7 +1,7 @@
-(allowed () "@start" "favicon.ico")
+#(allowed () "@start" "favicon.ico" n a)
-(load "@lib/http.l" "lib/xml.l")
-(load "er.l")
+#(load "@lib/http.l" "lib/xml.l")
+#(load "er.l")
(setq *Blob "blob/")
diff --git a/picowiki.l b/picowiki.l
@@ -1,361 +1,22 @@
-#!/home/thlavaty/picolisp/bin/picolisp /home/thlavaty/picolisp/lib.l
-# -*- picolisp -*-
+#!/home/tomas/picolisp/bin/picolisp /home/tomas/picolisp/lib.l
+# siege -b -c 5 http://localhost:8080
+
+# *Cp
+
+(load "@ext.l" "@lib/http.l" "@lib/xml.l")
+(load "er.l" "rcs.l" "rss.l")
+
+(allowed () "@start" p x b)
+
+###########################
-(setq *Dir "/home/thlavaty/Web/logand.com/picoWiki")
(setq *Host "logand.com") # TODO remove this
-(load "@ext.l" "@lib/http.l" "@lib/xhtml.l" "@lib/form.l" "@lib/xml.l")
-
-(off *JS)
-
-(de <b> Prg
- (tag 'b NIL 2 Prg))
-
-(de <sub> Prg
- (tag 'sub NIL 2 Prg))
-
-(de <sup> Prg
- (tag 'sup NIL 2 Prg))
-
-(de <legend> Prg
- (tag 'legend NIL 2 Prg))
-
-(de <href2> (Attr Str Url JS)
- (let *Style Attr
- (<href> Str Url JS)))
-
-(de <form> (Method Url . Prg)
- (tag 'form (list (cons 'method Method) (cons 'action Url)) 2 Prg))
-
-(de _markupWord ()
- (pack (make (until (or (eof) (member (peek) '("\\" "<" " " "^I" "^M" "^J")))
- (link (char))))))
-
-(de _markupSpace ()
- (let (N 0 S 0)
- (until (or (eof) (not (member (peek) '(NIL " " "^I" "^M" "^J"))))
- (let C (char)
- (ifn (= C "^J")
- (unless (= C "^M")
- (inc 'S))
- (inc 'N)
- (zero S))))
- (cons N S)))
-
-(de _markupCmd (Type)
- (case (peek)
- ("\\" (char))
- ("\<" (char))
- ("\~" (char) (cons 'nbsp NIL))
- ("="
- (case (till " ^I^M^J" T)
- ("=" T)
- ("==" (cons 'hr NIL))))
- ("{"
- (char)
- (prog1
- (cons (or Type 'lnk)
- (make
- (while (till "} ^I^M^J" T)
- (link @)
- (skip))))
- (char)))
- (T
- (cons (till "{ ^I^M^J" T)
- (when (= "{" (peek))
- (prog1
- (till "}" T) # TODO \{ inside {}
- (char)))))))
-
-(de till2 (End Pack)
- (let (X NIL
- E (flip (chop End))
- N (length E))
- (until (or (eof) (= (head N X) E))
- (push 'X (char)))
- (setq X (flip (nth X (+ N 1))))
- (if Pack (pack X) X)))
-
-(de _markupXml (End)
- (char)
- (let? C (till ">" T)
- (char)
- (unless (= C End)
- (if (member C '("pre" "lisp"))
- (cons C (till2 (pack "</" C ">")))
- (cons C (_markup (pack "/" C)))))))
-
-(de _markup (End)
- (let Space (member (peek) '(" " "^I" "^M" "^J"))
- (skip)
- (let Eop NIL
- (make # paragraphs
- (until (or Eop (eof))
- (when (make # words
- (while (and (not Eop)
- (case (peek)
- ("\\"
- (char)
- (let? X (_markupCmd)
- (when Space (link NIL))
- (link X)))
- ("<"
- (let X (_markupXml End)
- (ifn X
- (nil (on Eop))
- (when Space (link NIL))
- (link X))))
- (T
- (let? X (_markupWord)
- (when Space (link NIL))
- (link X))))
- (let X (_markupSpace)
- (setq Space (or (< 0 (cdr X))
- (= 1 (car X))))
- (< (car X) 2)))))
- (link @)))))))
-
-(setq *Xref
- (mapcar pack '(new sym str char name sp? pat? fun? all intern extern ==== loc box? str? ext? touch zap length size format chop pack glue pad align center text wrap pre? sub? low? upp? lowc uppc fold val getd set setq def de dm recur undef redef daemon patch xchg on off onOff zero one default expr subr let let? use accu push push1 pop cut del queue fifo idx lup cache locale dirname
- put get prop ; =: : :: putl getl wipe meta
- atom pair lst? num? sym? flg? sp? pat? fun? box? str? ext? bool not == n== = <> =0 =T n0 nT < <= > >= match
- + - * / % */ ** inc dec >> lt0 ge0 gt0 abs bit? & | x| sqrt seed rand max min length size accu format pad oct hex fmt64 money
- car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr cadddr cddddr nth con cons conc circ rot list need full make made chain link yoke copy mix append delete delq replace insert remove place strip split reverse flip trim clip head tail stem fin last member memq mmeq sect diff index offset assoc asoq rank sort uniq group length size val set xchg push push1 pop cut queue fifo idx balance get fill apply
- load args next arg rest pass quote as pid lit eval run macro curry def de dm recur recurse undef box new type isa method meth send try super extra with bind job let let? use and or nand nor xor bool not nil t prog prog1 prog2 if if2 ifn when unless cond nond case state while until loop do at for catch throw finally ! e $ sys call tick ipid opid kill quit task fork pipe later timeout bye
- apply pass maps map mapc maplist mapcar mapcon mapcan filter seek find pick cnt sum maxi mini fish by
- path in ipid out opid pipe ctl any sym str load hear tell key poll peek char skip eol eof from till line format scl read print println printsp prin prinl msg space beep tab flush rewind rd pr wr rpc wait sync echo info file dir lines open close port listen accept host connect nagle udp rc pretty pp show view here prEval mail
- *Class class dm rel var var: new type isa method meth send try object extend super extra with This
- pool journal id seq lieu lock begin commit rollback mark free dbck rel dbs dbs+ db: fmt64 tree root fetch store count leaf minKey maxKey genKey useKey init step scan iter prune zapTree chkTree db aux collect
- be goal prove -> unify ?
- pretty pp show loc debug vi ld trace lint lintAll fmt64
- argv opt gc raw alarm protect heap env up stk date time usec stamp dat$ $dat datSym datStr strDat expDat day week ultimo tim$ $tim telStr expTel locale allowed allow pwd cd chdir ctty info dir dirname call tick kill quit task fork pipe timeout mail test bye
- NIL *OS *DB T *Solo *PPid *Pid @ @@ @@@ This *Dbg *Zap *Scl *Class *Dbs *Run *Hup *Sig1 *Sig2 ^ *Err *Rst *Msg *Uni *Led *Adr *Allow *Fork *Bye)))
-
-(de xtok (L)
- (when (member (car L) '("(" " " "^I" "^J" "^M"))
- (let L (cdr L)
- (make
- (until (or (not L) (member (car L) '(")" " " "^I" "^J" "^M")))
- (link (car L))
- (setq L (cdr L)))))))
-
-(de ref (Tok)
- (let Tok2 (pack Tok)
- (when (member Tok2 *Xref)
- (cons
- Tok2
- (pack "http://www.software-lab.de/ref"
- (cond
- ((= "*" (car Tok))
- (uppc (cadr Tok)))
- ((member (lowc (car Tok))
- (chop "abcdefghijklmnopqrstuvwxyz"))
- (uppc (car Tok)))
- (T "_"))
- ".html#" Tok)))))
-
-(de xref (L)
- (let? Tok (xtok L)
- (ref Tok)))
-
-(de markupLisp (B)
- (let X (chop B)
- (while X
- (ifn (xref X)
- (ht:Prin (pop 'X))
- (prin (pop 'X))
- (<href> (car @) (cdr @))
- (do (length (car @)) (pop 'X))))))
-
-# ((pre? "blog:" (car B))
-# (let (BB1 (pack (cddr (car B)) " " (glue " " (cdr B)))
-# BB2 (glue " " B))
-# (<href2> 'i BB1 (pack "?" BB2))
-# (prin "<sup>β</sup>")))
-(de <ilink> (Page)
- (if (info (pageFile Page))
- (<href2> 'i Page Page)
- (ht:Prin Page)
- (<sup> (<href2> 'i "?" (pack Page "?e")))))
-
-(de pages ()
- (let P NIL
- (for F (sort (dir (pageFile)))
- (when (match '(@F "." "t" "x" "t") (chop F))
- (push 'P (pack @F))))
- (reverse P)))
-
-(de markup (Lst Par)
- (for (I . P) Lst
- (unless Par
- (prin "<p>"))
- (for (J . M) P
- (if (atom M)
- (cond
- ((=T M) (prin "<br/>"))
- ((not M) (prin " "))
- (T (ht:Prin M)))
- (let (H (car M) B (cdr M))
- (case H
- (lnk
- (cond
- ((pre? "http://" (car B))
- (<href2> 'e (or (glue " " (cdr B)) (car B)) (car B)))
- ((pre? "ref:" (car B))
- (let X (ref (tail -4 (chop (car B))))
- (<href2> 'ref (or (glue " " (cdr B)) (car X))
- (cdr X))))
- (T
- (<ilink> (glue " " B)))))
- (nbsp (<nbsp>))
- (hr (<hr>))
- ("pages"
- (<ul> NIL
- (for P (pages)
- (<li> NIL (<ilink> P)))))
-# ("ref"
-# (let X (ref (cdr (chop B)))
-# (<href2> 'ref (car X) (cdr X))))
- (("ul" "ol")
- (prin "<" H ">")
- (for Li (car B)
- (when (= "li" (car Li))
- (prin "<li>")
- (markup (cdr Li) (< (length (cdr Li)) 2))
- (prin "</li>")))
- (prin "</" H ">"))
- ("table"
- (prin "<" H ">")
- (for R (car B)
- (when (= "tr" (car R))
- (prin "<tr>")
- (for C (cadr R)
- (when (= "td" (car C))
- (prin "<td>")
- (markup (cdr C) (< (length (cdr C)) 2))
- (prin "</td>")))
- (prin "</tr>")))
- (prin "</" H ">"))
- (("h2" "h3" "b" "u")
- (prin "<" H ">")
- (markup B T)
- (prin "</" H ">"))
- ("pre"
- (prin "<" H ">")
- (ht:Prin B)
- (prin "</" H ">"))
- ("lisp"
- (prin "<pre class=\"lisp\">")
- (markupLisp B)
- (prin "</pre>"))
- ))))
- (unless Par
- (prin "</p>"))))
-
-(de renderView (Page)
- (<div> 'page
- (<h1> NIL (ht:Prin Page))
- (let F (pageFile Page)
- (if (info F)
- (in F (markup (_markup)))
- (<p> NIL "The page does not exist yet. "
- (<href> "Create the page now." (pageUrl Page 'edit)))))))
-
-(de readChanges (F)
- (let L NIL
- (in F
- (until (eof)
- (match '("\"" @D "\"" " "
- "\"" @T "\"" " "
- "\"" @N "\"" " "
- "\"" @P "\"" " "
- @V " "
- "\"" @C "\"") (line))
- (push 'L (mapcar pack (list @D @T @N @P @V @C)))))
- L))
-
-(de renderChanges (Page)
- (<div> '((class . "page changes"))
- (<h1> NIL
- (if (= "Changes" Page)
- (ht:Prin Page)
- (ht:Prin "'" Page "' changes")))
- (let F (pageFile "Changes")
- (ifn (info F)
- (<p> NIL "No changes have been made yet.")
- (let L (readChanges F)
- (for D (group (if (= "Changes" Page)
- L
- (filter '((X) (= Page (cadddr X))) L)))
- (<p> NIL
- (ht:Prin (httpDate2 (strDat (car D))))
- (<ul> NIL
- (for C (cdr D)
- (let (@T (car C)
- @N (cadr C)
- @P (caddr C)
- @V (cadddr C)
- @C (car (cddddr C)))
- (<li> NIL
- (ht:Prin @T)
- " " (<ilink> @P)
- " " (ht:Prin @V)
- ": " (ht:Prin @C)
- " -- " (<ilink> @N))))))))))))
-
-(de httpDate2 (Dat Tim)
- (let D (date Dat)
- (pack
- (day Dat *Day) ", "
- (pad 2 (caddr D)) " "
- (get *Mon (cadr D)) " "
- (car D)
- (when Tim " ")
- (when Tim (tim$ Tim T))
- (when Tim " GMT" ) ) ))
-
-(de rssItem (@D I)
- (when (match '(@T @N @P @V @C) I)
- (setq @T (car @T))
- (setq @N (car @N))
- (setq @P (car @P))
- (setq @V (car @V))
- (setq @C (car @C))
- (list 'item NIL
- (list 'title NIL
- (pack (httpDate2 (strDat @D)) " " @P " " @V ": " @C
- (when @N (pack " -- " @N))))
- (list 'pubDate NIL (httpDate2 (strDat @D) ($tim @T)))
- (list 'link NIL
- (pack "http://" *Host "/picoWiki/" (ht:Fmt (pageUrl @P 'view)))))))
-
-(de rss (Page)
- (httpHead "text/xml; charset=utf-8" 0)
- (ht:Out *Chunked
- (xml? T)
- (xml
- (list 'rss '((version . "0.92"))
- (make
- (link 'channel NIL
- '(title NIL "picoWiki Changes")
- (list 'link NIL (pack "http://" *Host "/picoWiki/Changes"))
- '(description NIL "picoWiki Changes"))
- (let F (pageFile "Changes")
- (when (info F)
- (let L (readChanges F)
- (for D (group L) # by date
- (for DD (by caddr group (cdr D)) # by page
- (let N (length DD)
- (link
- (rssItem (car D)
- (if (< 1 N)
- (list
- (caar DD)
- NIL
- (car (cddar DD))
- (cadr (cddar DD))
- (pack N " changes"))
- (car DD)))))))))))))))
+
+
+
+
+
(de renderEdit (Page)
(<form> "post" (pageUrl Page 'edit)
@@ -378,9 +39,6 @@
(<reset> "Reset")
(<href> ,"View page" (pageUrl Page 'view)))))
-(de mktemp ()
- (in (list "mktemp" "/tmp/picoWiki.XXXXXX")
- (line T)))
(de renderPreview (Page)
(<form> "post" (pageUrl Page 'edit)
@@ -400,9 +58,7 @@
(<submit> "Save")
(<href> ,"View page" (pageUrl Page 'view)))))
-(de nbsp (S)
- (pack (replace (chop S) " " " ")))
-
+
(de render (Page Mode)
(case Page
("rss" (rss))
@@ -487,46 +143,22 @@
(when (match '("h" "e" "a" "d" ":" " " "1" "." @N) L)
(throw 'version (format (pack @N)))))))))))
-(de post ()
- (mapcar '((X) (split X "=")) (split (in NIL (till NIL)) "&")))
-
-(de _htDecode (L)
- (ht:Pack (replace L "+" " ")))
-
-(de pageFile (Page)
- (if Page
- (pack *Dir "/pages/" Page ".txt")
- (pack *Dir "/pages")))
-
-(de readPage (Page)
- (let F (pageFile Page)
- (when (info F)
- (in F (till NIL T)))))
-
-(de rcsOut (F)
- (when (info F)
- (call "sh" "-c" (pack "co -l '" F "'"))))
-(de rcsIn (F Msg)
- (when (info F)
- (call "sh" "-c" (pack "ci -u -m'" Msg "' '" F "'"))))
(de editablePage (Page)
(not (member Page '("Changes" "rss"))))
-
+
(de writePage (Page Text Msg Name)
(let V (latestVersion Page)
(let F (pageFile Page)
- (rcsOut F)
- (out F (prin Text))
- (rcsIn F Msg))
+ (w/rcs F Msg
+ (out F (prin Text)) ) )
(let V2 (latestVersion Page)
(unless (= V V2)
(let F (pageFile "Changes")
- (rcsOut F)
- (out (pack "+" F)
- (println (datStr (date)) (tim$ (time T) T) Name Page V2 Msg))
- (rcsIn F "upd"))))))
+ (w/rcs F "upd"
+ (out (pack "+" F)
+ (println (datStr (date)) (tim$ (time T) T) Name Page V2 Msg) ) ) ) ) ) ) )
(de pageUrl (Page Mode)
(case Mode
@@ -536,42 +168,299 @@
(edit (pack Page "?e"))
(changes (pack Page "?c"))))
-(de cookies ()
- (mapcar '((X) (mapcar pack (split (chop X) "=")))
- (mapcar pack
- (mapcar clip (split (chop (sys "HTTP_COOKIE")) ";")))))
# P (or (if (pre? "@" Q) (pack (cdr (chop Q))) Q) "picoWiki") #####
-(let (M (sys "REQUEST_METHOD")
- Q (sys "QUERY_STRING")
- C (cookies)
- P (or (pack (cdr (chop (sys "PATH_INFO")))) "picoWiki"))
- (setq P (ht:Pack (chop P))) #(_htDecode (chop P)))
- (let? N (cadr (find '((X) (= (car X) "picoWiki.n")) C))
- (setq *N N)
- (on *R))
- (ifn (= "POST" M)
- (render P
- (case Q
- ("e" 'edit)
- ("c" 'changes)
- (T 'view)))
- (for X (post)
- (case (pack (car X))
- ("*T" (setq *T (_htDecode (cadr X))))
- ("*S" (setq *S (_htDecode (cadr X))))
- ("*C" (setq *C (_htDecode (cadr X))))
- ("*N" (setq *N (_htDecode (cadr X))))
- ("*R" (setq *R (_htDecode (cadr X))))
- ("*Q" (setq *Q (_htDecode (cadr X))))
- ("*P" (setq *P (_htDecode (cadr X))))))
- (ifn (and *T *S (= "pico" *C) *N)
- (render P 'edit)
- (ifn *P
- (prog
- (cookie "picoWiki.n" (when *R *N))
- (render P 'preview))
- (writePage P *T *S *N)
- (redirect P)))))
-
-(bye)
+## (let (M (sys "REQUEST_METHOD")
+## Q (sys "QUERY_STRING")
+## C (cookies)
+## P (or (pack (cdr (chop (sys "PATH_INFO")))) "picoWiki"))
+## (setq P (ht:Pack (chop P))) #(_htDecode (chop P)))
+## (let? N (cadr (find '((X) (= (car X) "picoWiki.n")) C))
+## (setq *N N)
+## (on *R))
+## (ifn (= "POST" M)
+## (render P
+## (case Q
+## ("e" 'edit)
+## ("c" 'changes)
+## (T 'view)))
+## (for X (post)
+## (case (pack (car X))
+## ("*T" (setq *T (_htDecode (cadr X))))
+## ("*S" (setq *S (_htDecode (cadr X))))
+## ("*C" (setq *C (_htDecode (cadr X))))
+## ("*N" (setq *N (_htDecode (cadr X))))
+## ("*R" (setq *R (_htDecode (cadr X))))
+## ("*Q" (setq *Q (_htDecode (cadr X))))
+## ("*P" (setq *P (_htDecode (cadr X))))))
+## (ifn (and *T *S (= "pico" *C) *N)
+## (render P 'edit)
+## (ifn *P
+## (prog
+## (cookie "picoWiki.n" (when *R *N))
+## (render P 'preview))
+## (writePage P *T *S *N)
+## (redirect P)))))
+
+
+#################################
+
+# TODO convert to unix line endings! ^M^J => ^J, ^M => ^J
+
+(de eatName (V)
+ (when (and (<= "A" (car (val V)) "Z") (<= "a" (cadr (val V)) "z"))
+ (make (link (pop V) (pop V))
+ (while (<= "a" (car (val V)) "z")
+ (link (pop V)) ) ) ) )
+
+(de eatWikiName (V)
+ (make
+ (while (eatName V)
+ (link @) ) ) )
+
+(de eatUrl (V)
+ (when (or (head '`(chop "http:") (val V))
+ (head '`(chop "https:") (val V))
+ (head '`(chop "mailto:") (val V)) )
+ (make
+ (while (and (val V) (not (member (car (val V)) '`(chop " ^I^J"))))
+ (link (pop V)) ) ) ) )
+
+(de pgName? (Nm)
+ (when Nm
+ (if (atom Nm)
+ (pgName? (chop Nm))
+ (let (L Nm W (eatWikiName 'L))
+ (and (not L) (cadr W) W) ) ) ) )
+
+(de markupLink (P)
+ (let Q (pack P)
+ (cond
+ ((member Q '("EditPage" "RecentChanges" "FindPage" "SignIn" "SignUp"))
+ (<xml> a href (pack "./?p=" *Cp "&x=" Q) (xprin P)) )
+ ((db 'nm '+Pg Q)
+ (<xml> a href (pack "./?p=" P) (xprin P)) )
+ (T (xprin P)
+ (<xml> a href (pack "./?p=" P "&x=EditPage") (xprin "?")) ) ) ) )
+
+(de markupUrl (U)
+ (cond
+ ((head '`(chop "mailto:") U)
+ (<xml> a href U (xprin (tail -7 U))) )
+ ((head '`(chop "http://ondoc.logand.com/") U)
+ (<xml> a href U (xprin "[OnDoc]")) )
+ ((head '`(chop "http://logand.com/") U)
+ (<xml> a href U (xprin "[LogAnd]")) )
+ ((or (head '`(chop "http://maps.google.com/") U)
+ (head '`(chop "http://maps.google.co.uk/") U) )
+ (<xml> a href U (xprin "[GoogleMap]")) )
+ ((head '`(chop "http://en.wikipedia.org/") U)
+ (<xml> a href U (xprin "[WikiPedia]")) )
+ ((head '`(chop "http://c2.com/") U)
+ (<xml> a href U (xprin "[WikiWikiWeb]")) )
+ ((head '`(chop "http://www.mail-archive.com/") U)
+ (<xml> a href U (xprin "[MailArchive]")) )
+ ((head '`(chop "http://www.reddit.com/") U)
+ (<xml> a href U (xprin "[RedditCom]")) )
+ ((head '`(chop "http://www.lispworks.com/documentation/HyperSpec/") U)
+ (<xml> a href U (xprin "[HyperSpec]")) )
+ ((head '`(chop "http://norvig.com/") U)
+ (<xml> a href U (xprin "[PeterNorvig]")) )
+ (T (<xml> a href U (xprin U))) ) )
+
+(de markupLine (L)
+ (when L
+ (while L
+ (let W (eatWikiName 'L)
+ (if W
+ (if (cadr W) # at least 2 names
+ (markupLink W)
+ (xprin W) )
+ (if (eatUrl 'L)
+ (markupUrl @)
+ (xprin (pop 'L)) ) ) ) ) ) )
+
+(de eatLine (V N) # TODO w/o make
+ (when N
+ (cut N V) )
+ (make
+ (until (or (= "^J" (car (val V))) (not (val V)))
+ (link (pop V)) )
+ (pop V) ) )
+
+(de listMarkup? (A)
+ (member A '`(chop "-+")) )
+
+(de listLevel (L)
+ (let N 0
+ (while (listMarkup? (pop 'L))
+ (inc 'N) )
+ N ) )
+
+(de markupText (L)
+ (while L
+ (cond
+ ((= "^J" (car L)) (pop 'L))
+ ((head '("=" " ") L) (<xml> h2 (xprin (eatLine 'L 2))))
+ ((head '("=" "=" " ") L) (<xml> h3 (xprin (eatLine 'L 3))))
+ ((head '("=" "=" "=" " ") L) (<xml> h4 (xprin (eatLine 'L 4))))
+ ((head '("=" "=" "=" "=" "=") L) (eatLine 'L) (<xml> hr))
+ ((= " " (car L))
+ (<xml> pre
+ (while (= " " (car L))
+ (xprin (eatLine 'L) "^J") ) ) )
+ ((listMarkup? (car L))
+ (let N 1
+ (recur (N)
+ (if (= "-" (pop 'L))
+ (<xml> ul
+ (if (listMarkup? (car L))
+ (recurse (+ 1 N))
+ (<xml> li (markupLine (eatLine 'L)))
+ (while (<= N (listLevel L))
+ (if (= N (listLevel L))
+ (<xml> li (markupLine (eatLine 'L N)) )
+ (cut N 'L)
+ (recurse (+ 1 N)) ) ) ) )
+ (<xml> ol
+ (if (listMarkup? (car L))
+ (recurse (+ 1 N))
+ (<xml> li (markupLine (eatLine 'L)))
+ (while (<= N (listLevel L))
+ (if (= N (listLevel L))
+ (<xml> li (markupLine (eatLine 'L N)) )
+ (cut N 'L)
+ (recurse (+ 1 N)) ) ) ) ) ) ) ) )
+ ((= ">" (car L)) (<xml> blockquote (xprin (eatLine 'L 1))))
+ ((= "|" (car L)) # TODO table
+ (<xml> pre
+ (while (= "|" (car L))
+ (xprin (eatLine 'L) "^J") ) ) )
+ (T (<xml> p
+ (markupLine (eatLine 'L))
+ (while (and (car L) (not (member (car L) '`(chop "= -+^J"))))
+ (<xml> br)
+ (markupLine (eatLine 'L)) ) ) ) ) ) )
+
+(de markupBlob (Blob)
+ (when (info Blob)
+ (let? L (in Blob (till))
+ (markupText L) ) ) )
+
+(de markupPage (P)
+ (let? Pg (db 'nm '+Pg P)
+ (markupBlob (blob Pg 'txt)) ) )
+
+(de pgView (P)
+ (let Pg (db 'nm '+Pg P)
+ (if Pg
+ (xhtml P # view
+ (<xml> div id "TopMenu" (markupPage "TopMenu"))
+ (<xml> h1
+ (<xml> img src "http://logand.com/logand1.png")
+ (xprin P) )
+ (markupBlob (blob Pg 'txt))
+ (<xml> div id "BottomMenu" (markupPage "BottomMenu")) )
+ (xhtml P # does not exist
+ (<xml> div id "TopMenu" (markupPage "TopMenu"))
+ (<xml> h1
+ (<xml> img src "http://logand.com/logand1.png")
+ (xprin P) )
+ (<xml> p
+ (xprin "Page ")
+ (markupLink P)
+ (xprin " does not exist.") )
+ (<xml> div id "BottomMenu" (markupPage "BottomMenu")) ) ) ) )
+
+(de pgEdit (P)
+ (xhtml P
+ (<xml> div id "TopMenu" (markupPage "TopMenu"))
+ (<xml> h1
+ (<xml> img src "http://logand.com/logand1.png")
+ (xprin "Edit " P) )
+ (<xml> form method "post" action (pack "./?p=" P "&x=SavePage")
+ enctype "multipart/form-data"
+ (<xml> p
+ (<xml> input type "submit" value "Save") )
+ (<xml> textarea wrap "virtual" cols "80" rows "18" name "b" id "b"
+ (when (db 'nm '+Pg P)
+ (in (blob @ 'txt)
+ (echo) ) ) ) )
+ (<xml> div id "BottomMenu" (markupPage "BottomMenu")) ) )
+
+(de pgSave (P B)
+ (if (db 'nm '+Pg P)
+ (let F (blob @ 'txt)
+ (w/rcs F "TODO put something useful here" P
+ (out F (prin B)) ) )
+ (let (Pg (new! '(+Pg) 'nm P) F (tmp "b"))
+ (out F (prin B))
+ (blob! Pg 'txt F)
+ (rcsIn (blob Pg 'txt) "Created" P) ) )
+ (redirect (pack "./?p=" P)) )
+
+(de pgPreview (P)
+ (xhtml P
+ (<xml> p (xprin "Preview " P)) ) )
+
+(de xhtml (Nm . Prg)
+ (httpHead "text/html" 0)
+ (ht:Out *Chunked
+ (<xml> NIL
+ (<xml> html xmlns "http://www.w3.org/1999/xhtml" xml:lang "en"
+ (<xml> head
+ (<xml> title (xprin Nm))
+ (<xml> meta
+ http-equiv "Content-Type"
+ content"text/html; charset=utf-8" )
+ (<xml> style NIL
+ "
+#TopMenu {float:right}
+#BottomMenu {text-align:center}
+#b {width:100%}
+h2 {border-bottom:solid 1px gray}
+/*textarea {border-bottom:solid 1px gray}*/
+/*body {max-width:42em}*/
+/*body {background-color:#eee}*/
+form {background-color:yellow}
+li {margin-top:0.5em;margin-bottom:0.5em}
+" )
+ (when *Fav
+ (<xml> link rel "icon" type "image/x-icon"
+ href *Fav )
+ (<xml> link rel "shortcut icon" type "image/x-icon"
+ href *Fav ) ) )
+ (<xml> body NIL (run Prg 1)) ) ) ) )
+
+(de start ()
+ (let (*Cp (get 'p 'http) X (get 'x 'http) B (get 'b 'http))
+ (cond
+ ((and (not X) (pgName? *Cp)) (pgView *Cp))
+ ((and (= "EditPage" X) (pgName? *Cp)) (pgEdit *Cp))
+ ((and (= "PreviewPage" X) (pgName? *Cp)) (pgPreview *Cp))
+ ((and (= "SavePage" X) (pgName? *Cp)) (pgSave *Cp B))
+ ## ((and (= "RecentChanges" X) (pgName? *Cp)) ...)
+ ## ((and (= "SignIn" X) (pgName? *Cp)) ...)
+ ## ((and (= "SignUp" X) (pgName? *Cp)) ...)
+ (T (xhtml "Error" (xprin "Error"))) ) ) )
+
+## (de start ()
+## (with (or (db 'nm '+Pg "LogAnd")
+## (new! '(+Pg) 'nm "LogAnd") )
+## (xhtml (: nm)
+## (<xml> p (xprin (: nm))) ) ) )
+
+(setq
+ *Blob "blob/"
+ *Fav "favicon.ico" )
+
+(de main ()
+ (call 'mkdir "-p" "db/" *Blob)
+ (pool "db/" *Dbs)
+ (unless (seq *DB)
+ (load "init.l") ) )
+
+(de go ()
+ (pw 12)
+ (rollback)
+ (server 8080 "@start") )
diff --git a/rcs.l b/rcs.l
@@ -0,0 +1,14 @@
+(de rcsOut (F)
+ (when (info F)
+ (call "sh" "-c" (pack "co -q -l '" F "'")) ) )
+
+(de rcsIn (F Msg Desc)
+ (when (info F)
+ (call "sh" "-c"
+ (pack "ci -q -u -m'" Msg "' -t-'" Desc "' '" F "'") ) ) )
+
+(de w/rcs (F Msg Desc . Prg)
+ (when (info F)
+ (rcsOut F)
+ (run Prg 1)
+ (rcsIn F Msg) ) )
diff --git a/rss.l b/rss.l
@@ -0,0 +1,99 @@
+(de readChanges (F)
+ (let L NIL
+ (in F
+ (until (eof)
+ (match '("\"" @D "\"" " "
+ "\"" @T "\"" " "
+ "\"" @N "\"" " "
+ "\"" @P "\"" " "
+ @V " "
+ "\"" @C "\"" ) (line) )
+ (push 'L (mapcar pack (list @D @T @N @P @V @C))) ) )
+ L ) )
+
+(de renderChanges (Page)
+ (<div> '((class . "page changes"))
+ (<h1> NIL
+ (if (= "Changes" Page)
+ (ht:Prin Page)
+ (ht:Prin "'" Page "' changes") ) )
+ (let F (pageFile "Changes")
+ (ifn (info F)
+ (<p> NIL "No changes have been made yet.")
+ (let L (readChanges F)
+ (for D (group (if (= "Changes" Page)
+ L
+ (filter '((X) (= Page (cadddr X))) L) ) )
+ (<p> NIL
+ (ht:Prin (httpDate2 (strDat (car D))))
+ (<ul> NIL
+ (for C (cdr D)
+ (let (@T (car C)
+ @N (cadr C)
+ @P (caddr C)
+ @V (cadddr C)
+ @C (car (cddddr C)) )
+ (<li> NIL
+ (ht:Prin @T)
+ " " (<ilink> @P)
+ " " (ht:Prin @V)
+ ": " (ht:Prin @C)
+ " -- " (<ilink> @N) ) ) ) ) ) ) ) ) ) ) )
+
+(de httpDate2 (Dat Tim)
+ (let D (date Dat)
+ (pack
+ (day Dat *Day) ", "
+ (pad 2 (caddr D)) " "
+ (get *Mon (cadr D)) " "
+ (car D)
+ (when Tim " ")
+ (when Tim (tim$ Tim T))
+ (when Tim " GMT") ) ) )
+
+(de rssItem (@D I)
+ (when (match '(@T @N @P @V @C) I)
+ (setq @T (car @T))
+ (setq @N (car @N))
+ (setq @P (car @P))
+ (setq @V (car @V))
+ (setq @C (car @C))
+ (<xml> item
+ (<xml> title
+ (xprin (httpDate2 (strDat @D)) " " @P " " @V ": " @C
+ (when @N (pack " -- " @N)) ) )
+ (<xml> pubDate (xprin (httpDate2 (strDat @D) ($tim @T))))
+ (<xml> link
+ (xprin "http://" *Host "/picoWiki/" (ht:Fmt (pageUrl @P 'view))) ) ) ) )
+
+# "2008-10-08" "16:04:09" "Tomas Hlavaty" "picoWiki" 1 "created"
+# date time who page version comment
+
+(de rss (Ttl Desc Pg)
+ (httpHead "text/xml; charset=utf-8" 0)
+ (ht:Out *Chunked
+ ##(xml? T)
+ (<xml> NIL
+ (<xml> rss version "0.92"
+ (<xml> channel
+ (<xml> title NIL Ttl)
+ (<xml> link (xprin "http://" *Host "/picoWiki/Changes"))
+ (<xml> description NIL Desc)
+
+ (let F (pageFile "Changes")
+ (when (info F)
+ (let L (readChanges F)
+ (for D (group L) # by date
+ (for DD (by caddr group (cdr D)) # by page
+ (let N (length DD)
+ (link
+ (rssItem (car D)
+ (if (< 1 N)
+ (list
+ (caar DD)
+ NIL
+ (car (cddar DD))
+ (cadr (cddar DD))
+ (pack N " changes") )
+ (car DD) ) ) ) ) ) ) ) ) ) ) ) ) ) )
+
