9 let document heading extra x
=
10 html ~a
:[a_xmlns `W3_org_1999_xhtml
; a_xml_lang
"en"]
11 (head
(title
(t heading
)) extra
)
14 let doc heading x
= document heading
[] x
16 let input_text ~title ?
(id
="") ?
(init
="") () =
17 form ~a
:[a_method `Post
] ~action
:(uri_of_string
"")
20 (p
[textarea ~rows
:20 ~cols
:80 ~a
:[a_name
"text"] (t init
)]);
22 input ~a
:[a_name
"id"; a_value id
; a_input_type `Hidden
] ();
23 input ~a
:[a_name
"submit"; a_value
"Submit"; a_input_type `Submit
] ()
27 let ahref s
= a ~a
:[a_href
(uri_of_string s
)]
33 let arg x
= catch
(fun args
-> let a = List.find
(fun a -> a#name
= x
) args
in a#
value)
35 type location
= string
37 (* **************************** *)
40 module Store
= Storage.Fs
42 let rec resolve self url
=
43 if url
= self#url
then self
44 else List.find
(fun child
-> try ignore
(resolve child url
); true with Not_found
-> false) self#children
48 method virtual url
: location
49 method virtual name
: string
50 method virtual children
: base list
51 method virtual render
: <name
:string;value:string> list
-> html
54 let header self pages
=
55 let name x
= if Oo.id x
= Oo.id self
then [b
[t x#
name]] else [t x#
name] in
56 div
[p
(List.map
(fun p
-> [ahref p#url
(name p
); space
()]) pages
>> List.flatten
); hr
()]
58 let render_markdown s
=
59 let module SM
= Simple_markup
in
60 let render_pre ~kind s
= t s
61 and render_link href
= ahref href
.SM.href_target
[t href
.SM.href_desc
]
62 and render_img i
= img ~src
:(uri_of_string i
.SM.img_src
) ~alt
:i
.SM.img_alt
() in
63 s
>> SM.parse_text
>> Simple_markup__html.to_html ~
render_pre ~render_link ~render_img
66 match Store.get store
(`S
"index") with
68 | Some s
-> Marshal.from_string s
0
70 let log_exn e fmt
= Printf.ksprintf print_endline fmt
72 class view_comment anc
= object(self
)
76 method name = z#view_comment
78 let store = Store.create
"comments" in
81 (fun x
-> li
[ahref (Printf.sprintf
"%s?id=%u" self#url x
) [t (string_of_int x
)]])
82 (List.sort ~cmp
:compare
(get_index store)))
84 let content = match arg "id" args
with
88 match Store.get
store (`I
(int_of_string v
)) with
89 | Some s
-> render_markdown s
>> div
90 | None
-> div
[h1
[t (z#no_item v
)]; show_index ()]
91 with e
-> log_exn e
"view_comments(%s)" v
; show_index ()
93 | None
-> show_index ()
103 exception Redirect
of string
105 class comment ctx
= object(self
)
108 method url
= "/comment"
109 method name = z#add_comment
112 match arg "text" args
with
114 let store = Store.create
"comments" in
115 let index = get_index store in
116 let id = match List.sort ~cmp
:(flip compare
) index with
120 (* FIXME atomicity *)
121 Store.add
store (`S
"index") (Marshal.to_string
(id::index) []);
122 Store.add
store (`I
id) text;
123 raise
(Redirect
(Printf.sprintf
"/view?id=%u" id))
124 | None
-> div
[p
[t ""]]
130 input_text self#
name ()
134 class edit_comment ctx
= object(self
)
137 method url
= "/edit_comment"
138 method name = z#edit_comment
140 let store = Store.create
"comments" in
143 (fun x
-> li
[ahref (Printf.sprintf
"%s?id=%u" self#url x
) [t (string_of_int x
)]])
144 (List.sort ~cmp
:compare
(get_index store)))
147 match arg "id" args
, arg "text" args
with
148 | Some n
, Some
text ->
149 let n = int_of_string
n in
150 (match Store.get
store (`I
n) with
151 | Some _
-> Store.add
store (`I
n) text
153 raise
(Redirect
(Printf.sprintf
"/view?id=%u" n))
164 input_text ~init
:(Store.get
store (`I
(int_of_string
n)) >> Option.default
"") ~
id:n ~title
:self#
name ()
167 | Redirect r
-> raise
(Redirect r
)
168 | e
-> log_exn e
"edit_comment"; doc self#
name [ header self
[ctx
]; show_index ()]
171 class main
= object(self
)
173 method comment
= new comment self
174 method children
= ([new comment self
; new view_comment self
; new edit_comment self
]:>base list
)
176 method name = z#main_page
181 ul (List.map
(fun x
-> li
[ahref x#url
[t x#
name]]) self#children
);
187 class not_found url
=
192 method name = z#not_found
197 p
[t "Url "; b
[t url
]; t " not found."];