picowiki.l (19032B)
1 #!/home/tomas/picolisp/bin/picolisp /home/tomas/picolisp/lib.l 2 # siege -b -c 5 http://localhost:8080 3 4 # *Cp 5 6 (load "@ext.l" "@lib/http.l" "@lib/xml.l") 7 (load "er.l" "rcs.l" "rss.l") 8 9 (allowed () "@start" p x b) 10 11 ########################### 12 13 (setq *Host "logand.com") # TODO remove this 14 15 16 17 18 19 20 21 (de renderEdit (Page) 22 (<form> "post" (pageUrl Page 'edit) 23 (<h1> NIL (ht:Prin "Edit '" Page "' page")) 24 (let *T (readPage Page) 25 (<area> 78 20 '*T)) 26 (<p> NIL 27 (<b> ,"Summary of changes:") " " (<field> 40 '*S)) 28 (<p> NIL 29 (<b> ,"Captcha (enter the word 'pico' here):") " " 30 (<field> 10 '*C)) 31 (<p> NIL 32 (<b> ,"Your name:") " " (<field> 40 '*N)) 33 (<p> NIL 34 (<check> '*R) 35 (<b> ,"Check this box to fill in your name automatically next time") 36 ," (uses a cookie)") 37 (<p> NIL 38 (<submit> "Preview") 39 (<reset> "Reset") 40 (<href> ,"View page" (pageUrl Page 'view))))) 41 42 43 (de renderPreview (Page) 44 (<form> "post" (pageUrl Page 'edit) 45 (<div> 'page 46 (<h1> NIL (ht:Prin "Preview '" Page "' page")) 47 (let F (mktemp) 48 (out F (prin *T)) 49 (in F (markup (_markup))) 50 (call "rm" "-f" F))) 51 (<p> NIL 52 (<hidden> '*T *T) 53 (<hidden> '*S *S) 54 (<hidden> '*C *C) 55 (<hidden> '*N *N) 56 (<hidden> '*R *R) 57 (<hidden> '*P T) 58 (<submit> "Save") 59 (<href> ,"View page" (pageUrl Page 'view))))) 60 61 62 (de render (Page Mode) 63 (case Page 64 ("rss" (rss)) 65 (T 66 (let F (pageFile Page) 67 (html 68 # TODO allow caching (if Edit 0 (* 60 60 24 1)) # 1 day 69 (unless (= Mode 'view) 0) 70 (pack "picoWiki: " Page) 71 (pack "http://" *Host "/picoWiki/picoWiki.css") NIL 72 #== 73 (<form> "post" (pageUrl Page 'search) 74 (<p> 'menu 75 "picoWiki:" 76 " " (<href2> 'i "Home" (pageUrl "picoWiki" 'view)) 77 " " (<ilink> "All") 78 " " (<ilink> "Changes") 79 " " (<ilink> "Formatting") 80 " " (<ilink> "Sandbox") 81 (when (and (info F) (editablePage Page)) 82 (prin " | ") (<href> ,"Edit" (pageUrl Page 'edit)) 83 (prin " ") (<href> ,"History" (pageUrl Page 'changes))) 84 " " (<field> 20 '*Q) (<submit> "Search"))) 85 (<hr>) 86 (case Page 87 ("Changes" (renderChanges Page)) 88 (T (case Mode 89 (view (renderView Page)) 90 (edit (renderEdit Page)) 91 (preview (renderPreview Page)) 92 (changes (renderChanges Page))))) 93 (<hr>) 94 (<p> NIL 95 "This page is linked from:" 96 (for P (grep Page) 97 (unless (= P Page) 98 (prin " ") (<href2> 'i P (pageUrl P 'view))))) 99 (<p> NIL 100 (when (info F) 101 (prin "Revisions: ") 102 (let (V (latestVersion Page) 103 C V) 104 (for N '(9 8 7 6 5 4 3 2 1 0) 105 (let W (- V N) 106 (when (< 0 W) 107 (prin " ") 108 (if (= W C) 109 (<b> W) 110 (prin W)))))) 111 (prin " ") 112 (<href> ,"View source" (pageUrl Page 'source)) 113 (prin " XHTML") 114 (<sup> 115 (<href2> 'e "V" 116 (pack "http://validator.w3.org/check?uri=" 117 "http://" *Host "/picoWiki/" (pageUrl Page 'view)))) 118 (prin " | ")) 119 (<href> ,"RSS" (pageUrl "rss" 'view)) 120 (<sup> 121 (<href2> 'e "V" 122 (pack "http://feedvalidator.org/check.cgi?url=" 123 "http://" *Host "/picoWiki/" (pageUrl "rss" 'view))))) 124 (<p> NIL 125 "picoWiki pages can be edited by anyone at any time. Imagine a fearsomely comprehensive disclaimer of liability. Now fear, comprehensively")))))) 126 127 (de grep (Page) 128 (chdir (pageFile) 129 (in (list "sh" "-c" (pack "grep '\{" Page "}' *.txt")) 130 (let X NIL 131 (until (eof) 132 (push1 'X 133 (pack (reverse (cddddr (reverse (car (split (line) ":")))))))) 134 X)))) 135 136 (de latestVersion (Page) 137 (let? F (pageFile Page) 138 (when (info F) 139 (in (list "rlog" "-h" F) 140 (catch 'version 141 (until (eof) 142 (let L (line) 143 (when (match '("h" "e" "a" "d" ":" " " "1" "." @N) L) 144 (throw 'version (format (pack @N))))))))))) 145 146 147 148 (de editablePage (Page) 149 (not (member Page '("Changes" "rss")))) 150 151 (de writePage (Page Text Msg Name) 152 (let V (latestVersion Page) 153 (let F (pageFile Page) 154 (w/rcs F Msg 155 (out F (prin Text)) ) ) 156 (let V2 (latestVersion Page) 157 (unless (= V V2) 158 (let F (pageFile "Changes") 159 (w/rcs F "upd" 160 (out (pack "+" F) 161 (println (datStr (date)) (tim$ (time T) T) Name Page V2 Msg) ) ) ) ) ) ) ) 162 163 (de pageUrl (Page Mode) 164 (case Mode 165 (source (pack "/picoWiki/pages/" Page ".txt")) 166 (view Page) 167 (search "?s") 168 (edit (pack Page "?e")) 169 (changes (pack Page "?c")))) 170 171 172 # P (or (if (pre? "@" Q) (pack (cdr (chop Q))) Q) "picoWiki") ##### 173 ## (let (M (sys "REQUEST_METHOD") 174 ## Q (sys "QUERY_STRING") 175 ## C (cookies) 176 ## P (or (pack (cdr (chop (sys "PATH_INFO")))) "picoWiki")) 177 ## (setq P (ht:Pack (chop P))) #(_htDecode (chop P))) 178 ## (let? N (cadr (find '((X) (= (car X) "picoWiki.n")) C)) 179 ## (setq *N N) 180 ## (on *R)) 181 ## (ifn (= "POST" M) 182 ## (render P 183 ## (case Q 184 ## ("e" 'edit) 185 ## ("c" 'changes) 186 ## (T 'view))) 187 ## (for X (post) 188 ## (case (pack (car X)) 189 ## ("*T" (setq *T (_htDecode (cadr X)))) 190 ## ("*S" (setq *S (_htDecode (cadr X)))) 191 ## ("*C" (setq *C (_htDecode (cadr X)))) 192 ## ("*N" (setq *N (_htDecode (cadr X)))) 193 ## ("*R" (setq *R (_htDecode (cadr X)))) 194 ## ("*Q" (setq *Q (_htDecode (cadr X)))) 195 ## ("*P" (setq *P (_htDecode (cadr X)))))) 196 ## (ifn (and *T *S (= "pico" *C) *N) 197 ## (render P 'edit) 198 ## (ifn *P 199 ## (prog 200 ## (cookie "picoWiki.n" (when *R *N)) 201 ## (render P 'preview)) 202 ## (writePage P *T *S *N) 203 ## (redirect P))))) 204 205 206 ################################# 207 208 # TODO convert to unix line endings! ^M^J => ^J, ^M => ^J 209 210 (de eatName (V) 211 (when (and (<= "A" (car (val V)) "Z") (<= "a" (cadr (val V)) "z")) 212 (make (link (pop V) (pop V)) 213 (while (<= "a" (car (val V)) "z") 214 (link (pop V)) ) ) ) ) 215 216 (de eatWikiName (V) 217 (make 218 (while (eatName V) 219 (link @) ) ) ) 220 221 (de eatUrl (V) 222 (when (or (head '`(chop "http:") (val V)) 223 (head '`(chop "https:") (val V)) 224 (head '`(chop "mailto:") (val V)) ) 225 (make 226 (while (and (val V) (not (member (car (val V)) '`(chop " ^I^J")))) 227 (link (pop V)) ) ) ) ) 228 229 (de pgName? (Nm) 230 (when Nm 231 (if (atom Nm) 232 (pgName? (chop Nm)) 233 (let (L Nm W (eatWikiName 'L)) 234 (and (not L) (cadr W) W) ) ) ) ) 235 236 (de markupLink (P) 237 (let Q (pack P) 238 (cond 239 ((member Q '("EditPage" "RecentChanges" "FindPage" "SignIn" "SignUp")) 240 (<xml> a href (pack "./?p=" *Cp "&x=" Q) (xprin P)) ) 241 ((db 'nm '+Pg Q) 242 (<xml> a href (pack "./?p=" P) (xprin P)) ) 243 (T (xprin P) 244 (<xml> a href (pack "./?p=" P "&x=EditPage") (xprin "?")) ) ) ) ) 245 246 (de markupUrl (U) 247 (cond 248 ((head '`(chop "mailto:") U) 249 (<xml> a href U (xprin (tail -7 U))) ) 250 ((head '`(chop "http://ondoc.logand.com/") U) 251 (<xml> a href U (xprin "[OnDoc]")) ) 252 ((head '`(chop "http://logand.com/") U) 253 (<xml> a href U (xprin "[LogAnd]")) ) 254 ((or (head '`(chop "http://maps.google.com/") U) 255 (head '`(chop "http://maps.google.co.uk/") U) ) 256 (<xml> a href U (xprin "[GoogleMap]")) ) 257 ((head '`(chop "http://en.wikipedia.org/") U) 258 (<xml> a href U (xprin "[WikiPedia]")) ) 259 ((head '`(chop "http://c2.com/") U) 260 (<xml> a href U (xprin "[WikiWikiWeb]")) ) 261 ((head '`(chop "http://www.mail-archive.com/") U) 262 (<xml> a href U (xprin "[MailArchive]")) ) 263 ((head '`(chop "http://www.reddit.com/") U) 264 (<xml> a href U (xprin "[RedditCom]")) ) 265 ((head '`(chop "http://www.lispworks.com/documentation/HyperSpec/") U) 266 (<xml> a href U (xprin "[HyperSpec]")) ) 267 ((head '`(chop "http://norvig.com/") U) 268 (<xml> a href U (xprin "[PeterNorvig]")) ) 269 (T (<xml> a href U (xprin U))) ) ) 270 271 (de markupLine (L) 272 (when L 273 (while L 274 (ifn (= "=" (car L)) #(member (car L) '`(chop "=*/")) 275 (let W (eatWikiName 'L) 276 (if W 277 (if (cadr W) # at least 2 names 278 (markupLink W) 279 (xprin W) ) 280 (if (eatUrl 'L) 281 (markupUrl @) 282 (xprin (pop 'L)) ) ) ) 283 (case (pop 'L) # TODO these only starting outside words 284 ("=" 285 (<xml> code 286 (while (and (car L) (not (= "=" (car L)))) 287 (xprin (pop 'L)) ) ) ) 288 ("*" 289 (<xml> b 290 (while (and (car L) (not (= "*" (car L)))) 291 (xprin (pop 'L)) ) ) ) 292 ("/" 293 (<xml> i 294 (while (and (car L) (not (= "/" (car L)))) 295 (xprin (pop 'L)) ) ) ) ) 296 (pop 'L) ) ) ) ) 297 298 (de eatLine (V N) # TODO w/o make 299 (when N 300 (cut N V) ) 301 (make 302 (until (or (= "^J" (car (val V))) (not (val V))) 303 (link (pop V)) ) 304 (pop V) ) ) 305 306 (de listMarkup? (A) 307 (member A '`(chop "-+")) ) 308 309 (de listLevel (L) 310 (let N 0 311 (while (listMarkup? (pop 'L)) 312 (inc 'N) ) 313 N ) ) 314 315 ## (de parseToc (L) 316 ## (make 317 ## (while L 318 ## (cond 319 ## ((head '("=" " ") L) 320 ## (link (eatLine 'L 2)) 321 ## (while (and (car L) (head '("=" " ") L)) 322 ## (link (eatLine 'L 2)) ) 323 ## ((head '("=" "=" " ") L) (link (eatLine 'L 3))) 324 ## ((head '("=" "=" "=" " ") L) (link (eatLine 'L 4))) 325 ## (T (eatLine 'L)) ) ) ) ) ) 326 327 (de markupText (L) 328 (let (Toc NIL H1 NIL Pre) 329 (while L 330 (cond 331 ((= "^J" (car L)) (pop 'L)) 332 ((head '("#" "+" "t" "o" "c" "^J") L) 333 (eatLine 'L) 334 (setq Toc '("one" "two" "three")) ) # TODO 335 ((or (head '`(chop "#+pre text") L) 336 (head '`(chop "#+pre java") L) ) 337 (setq Pre (pack (eatLine 'L 6))) ) 338 ((head '("=" " ") L) 339 (when (and Toc (not H1)) 340 (<xml> h2 (xprin "Contents ") 341 (<xml> a class "a" href "#0" NIL "⚓") ) # TODO anchor numbering 342 (<xml> ul 343 (for X Toc 344 (<xml> li (xprin X)) ) ) ) 345 (on H1) 346 (<xml> h2 (xprin (eatLine 'L 2) " ") 347 (<xml> a class "a" href "#0" NIL "⚓") ) ) 348 ((head '("=" "=" " ") L) 349 (<xml> h3 (xprin (eatLine 'L 3) " ") 350 (<xml> a class "a" href "#0" NIL "⚓") ) ) 351 ((head '("=" "=" "=" " ") L) 352 (<xml> h4 (xprin (eatLine 'L 4) " ") 353 (<xml> a class "a" href "#0" NIL "⚓") ) ) 354 ((head '("=" "=" "=" "=" "=") L) (eatLine 'L) (<xml> hr)) 355 ((= " " (car L)) 356 (<xml> pre style (case Pre 357 ("text" "background-color:#f7f5f3;border:1pt solid #ccbdae;padding:0.5em") 358 ("java" "background-color:#f3f5f7;border:1pt solid #aebdcc;padding:0.5em") ) 359 (let N 0 360 (while (= " " (car L)) 361 (do N (xprin "^J")) 362 (xprin (eatLine 'L 1) "^J") 363 (setq N 0) 364 (while (= "^J" (car L)) 365 (pop 'L) 366 (inc 'N) ) ) ) ) ) 367 ((= 1 (listLevel L)) 368 (let N 1 369 (recur (N) 370 (let (li '((N) 371 (markupLine (eatLine 'L N)) 372 (while (= "." (car L)) 373 (pop 'L) 374 (case (car L) 375 ((= "^J" (car L)) (pop 'L)) 376 ((= " " (car L)) 377 (<xml> pre style (case Pre 378 ("text" "background-color:#f7f5f3;border:1pt solid #ccbdae;padding:0.5em") 379 ("java" "background-color:#f3f5f7;border:1pt solid #aebdcc;padding:0.5em") ) 380 # TODO like pre above 381 (xprin (eatLine 'L 1) "^J") 382 (while (head '("." " ") L) 383 (xprin (eatLine 'L 2) "^J") ) ) ) 384 (T (<xml> p 385 (markupLine (eatLine 'L)) 386 (while (and (= "." (car L)) 387 (not (member (cadr L) 388 '`(chop " ^J") ) ) ) 389 (<xml> br) 390 (markupLine (eatLine 'L 1)) ) ) ) ) ) ) 391 lic '(() 392 (if (listMarkup? (car L)) 393 (recurse (+ 1 N)) 394 (<xml> li (li)) 395 (while (<= N (listLevel L)) 396 (if (= N (listLevel L)) 397 (<xml> li (li N)) 398 (cut N 'L) 399 (recurse (+ 1 N)) ) ) ) ) ) 400 (if (= "-" (pop 'L)) 401 (<xml> ul (lic)) 402 (<xml> ol (lic)) ) ) ) ) ) 403 ((= ">" (car L)) 404 (<xml> blockquote (xprin (markupLine (eatLine 'L 1)))) ) 405 ((= "|" (car L)) # TODO table 406 (<xml> pre 407 (while (= "|" (car L)) 408 (xprin (eatLine 'L) "^J") ) ) ) 409 (T (<xml> p 410 (markupLine (eatLine 'L)) 411 (while (and (car L) (not (member (car L) '`(chop "= -+^J")))) 412 (<xml> br) 413 (markupLine (eatLine 'L)) ) ) ) ) ) ) ) 414 415 (de markupBlob (Blob) 416 (when (info Blob) 417 (let? L (in Blob (till)) 418 (markupText L) ) ) ) 419 420 (de markupPage (P) 421 (let? Pg (db 'nm '+Pg P) 422 (markupBlob (blob Pg 'txt)) ) ) 423 424 (de pgView (P) 425 (let Pg (db 'nm '+Pg P) 426 (if Pg 427 (xhtml P # view 428 (<xml> div id "TopMenu" (markupPage "TopMenu")) 429 (<xml> h1 430 (<xml> img src "http://logand.com/logand1.png") 431 (xprin P) ) 432 (markupBlob (blob Pg 'txt)) 433 (<xml> div id "BottomMenu" (markupPage "BottomMenu")) ) 434 (xhtml P # does not exist 435 (<xml> div id "TopMenu" (markupPage "TopMenu")) 436 (<xml> h1 437 (<xml> img src "http://logand.com/logand1.png") 438 (xprin P) ) 439 (<xml> p 440 (xprin "Page ") 441 (markupLink P) 442 (xprin " does not exist.") ) 443 (<xml> div id "BottomMenu" (markupPage "BottomMenu")) ) ) ) ) 444 445 (de pgEdit (P) 446 (xhtml P 447 (<xml> div id "TopMenu" (markupPage "TopMenu")) 448 (<xml> h1 449 (<xml> img src "http://logand.com/logand1.png") 450 (xprin "Edit " P) ) 451 (<xml> form method "post" action (pack "./?p=" P "&x=SavePage") 452 enctype "multipart/form-data" 453 (<xml> p 454 (<xml> input type "submit" value "Save") ) 455 (<xml> textarea wrap "virtual" cols "80" rows "18" name "b" id "b" 456 (when (db 'nm '+Pg P) 457 (in (blob @ 'txt) 458 (echo) ) ) ) ) 459 (<xml> div id "BottomMenu" (markupPage "BottomMenu")) ) ) 460 461 (de pgSave (P B) 462 (if (db 'nm '+Pg P) 463 (let F (blob @ 'txt) 464 (w/rcs F "TODO put something useful here" P 465 (out F (prin B)) ) ) 466 (let (Pg (new! '(+Pg) 'nm P) F (tmp "b")) 467 (out F (prin B)) 468 (blob! Pg 'txt F) 469 (rcsIn (blob Pg 'txt) "Created" P) ) ) 470 (redirect (pack "./?p=" P)) ) 471 472 (de pgPreview (P) 473 (xhtml P 474 (<xml> p (xprin "Preview " P)) ) ) 475 476 (de xhtml (Nm . Prg) 477 (httpHead "text/html" 0) 478 (ht:Out *Chunked 479 (<xml> NIL 480 (<xml> html xmlns "http://www.w3.org/1999/xhtml" xml:lang "en" 481 (<xml> head 482 (<xml> title (xprin Nm)) 483 (<xml> meta 484 http-equiv "Content-Type" 485 content"text/html; charset=utf-8" ) 486 (<xml> style NIL 487 " 488 #TopMenu {float:right} 489 #BottomMenu {text-align:center} 490 #b {width:100%} 491 h2 {border-bottom:solid 1px gray} 492 a.a {text-decoration:none} 493 /*textarea {border-bottom:solid 1px gray}*/ 494 /*body {max-width:42em}*/ 495 /*body {background-color:#eee}*/ 496 form {background-color:yellow} 497 li {margin-top:0.5em;margin-bottom:0.5em} 498 " ) 499 (when *Fav 500 (<xml> link rel "icon" type "image/x-icon" 501 href *Fav ) 502 (<xml> link rel "shortcut icon" type "image/x-icon" 503 href *Fav ) ) ) 504 (<xml> body NIL (run Prg 1)) ) ) ) ) 505 506 (de start () 507 (let (*Cp (get 'p 'http) X (get 'x 'http) B (get 'b 'http)) 508 (cond 509 ((and (not X) (pgName? *Cp)) (pgView *Cp)) 510 ((and (= "EditPage" X) (pgName? *Cp)) (pgEdit *Cp)) 511 ((and (= "PreviewPage" X) (pgName? *Cp)) (pgPreview *Cp)) 512 ((and (= "SavePage" X) (pgName? *Cp)) (pgSave *Cp B)) 513 ## ((and (= "RecentChanges" X) (pgName? *Cp)) ...) 514 ## ((and (= "SignIn" X) (pgName? *Cp)) ...) 515 ## ((and (= "SignUp" X) (pgName? *Cp)) ...) 516 (T (xhtml "Error" (xprin "Error"))) ) ) ) 517 518 ## (de start () 519 ## (with (or (db 'nm '+Pg "LogAnd") 520 ## (new! '(+Pg) 'nm "LogAnd") ) 521 ## (xhtml (: nm) 522 ## (<xml> p (xprin (: nm))) ) ) ) 523 524 (setq 525 *Blob "blob/" 526 *Fav "favicon.ico" ) 527 528 (de main () 529 (call 'mkdir "-p" "db/" *Blob) 530 (pool "db/" *Dbs) 531 (unless (seq *DB) 532 (load "init.l") ) ) 533 534 (de go () 535 (pw 12) 536 (rollback) 537 (server 8080 "@start") )