forked from laarc/laarc
-
Notifications
You must be signed in to change notification settings - Fork 1
/
blog.arc
executable file
·118 lines (93 loc) · 2.72 KB
/
blog.arc
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
#!bin/arc
; Blog tool example. 20 Jan 08, rev 21 May 09.
; To run:
; $ ./blog.arc
; or run from a repl:
; arc> (load "blog.arc")
; arc> (bsv)
; go to http://localhost:8080
; $ echo test > arc/admins
; click "new post", then create a user named test
(= postdir* (libpath "arc/posts/")
blogtitle* "A Blog")
(or= postid* 0 posts* (table))
(deftem post id nil title nil text nil)
(def load-posts ()
(each id (map int (dir postdir*))
(= postid* (max postid* 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" "/archive")
(link "new post" "/newpost"))))))
(defop viewpost req (blogop post-page arg!id))
(def blogop (f id)
(aif (post id)
(f it)
(is id t)
(f)
(blogpage (pr "No such post."))))
(def blogopa (f id whence) (admin-gate whence blogop f id))
(def post-url (id) (string "/viewpost?id=" id))
(def edit-post-url (id) (string "/editpost?id=" id))
(def post-page (p) (blogpage (display-post p)))
(def display-post (p)
(tag b (link p!title (post-url p!id)))
(when (get-user)
(sp)
(link "[edit]" (edit-post-url p!id)))
(br2)
(pr p!text))
(defop newpost req (blogopa new-post-page t "/newpost"))
(def new-post-page ()
(blogpage
(urform (get-user) req
(let p (addpost arg!t (md-from-form arg!b))
(post-url p!id))
(tab (row "title" (input "t" "" 60))
(row "text" (textarea "b" 10 80))
(row "" (submit))))))
(def addpost (title text)
(let p (inst 'post 'id (++ postid*) 'title title 'text text)
(save-post p)
(= (posts* p!id) p)))
(defop editpost req (blogopa edit-post-page arg!id (edit-post-url arg!id)))
(def edit-post-page (p)
(blogpage
(display-post p)
(br2)
(vars-form `((string title ,p!title t t)
(mdtext text ,p!text t t))
(fn (name val) (= (p name) val))
(fn () (save-post p)
(edit-post-url p!id)))))
(defop archive req
(blogpage
(tag ul
(down i postid* 1
(whenlet p (post i)
(tag li (link p!title (post-url p!id))
(when (get-user)
(sp)
(link "[edit]" (edit-post-url p!id)))))))))
(def blogmain ()
(blogpage
(for i 0 4
(awhen (posts* (- postid* i))
(display-post it)
(br 3)))))
(defop blog req (blogmain))
(defop || req (blogmain))
(def bsv ((o port 8080))
(ensure-dir postdir*)
(load-posts)
(asv port))
bsv