1 files changed, 95 insertions, 0 deletions
diff --git a/blog.arc b/blog.arc
new file mode 100644
index 0000000..211dd63
--- /dev/null
+++ b/blog.arc
@@ -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))
+
+