From 1fb8c8b10346b59ef1f7629fc80fd30dc0497e75 Mon Sep 17 00:00:00 2001 From: ygrek Date: Sun, 20 Sep 2009 20:41:28 +0300 Subject: [PATCH] add comments --- lang.ml | 4 ++++ main.ml | 4 ++-- page.ml | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++------ request.ml | 30 ++++++++++++++++++++---------- 4 files changed, 83 insertions(+), 18 deletions(-) diff --git a/lang.ml b/lang.ml index be62977..0deb09a 100644 --- a/lang.ml +++ b/lang.ml @@ -1,4 +1,6 @@ +open Printf + class en = object method main_page = "Main page" method add_comment = "Add comment" @@ -9,4 +11,6 @@ class ru = object inherit en method main_page = "Главная страница" method add_comment = "Добавить комментарий" +method view_comment = "Просмотреть комментарий" +method no_item = sprintf "Нет такого : %s" end diff --git a/main.ml b/main.ml index 2984237..5583bac 100644 --- a/main.ml +++ b/main.ml @@ -16,13 +16,13 @@ let fcgi_port = !fcgi_port let run_cgi () = Netcgi_cgi.run ~output_type:(`Direct "") - Request.main + (Request.main true) let run_fcgi () = Netcgi_fcgi.run ~sockaddr:(Unix.ADDR_INET (Unix.inet_addr_loopback,fcgi_port)) ~output_type:(`Direct "") - (fun cgi -> Request.main (cgi:>Netcgi.cgi)) + (Request.main false) let main () = match fcgi_port with diff --git a/page.ml b/page.ml index 3f6af3b..90a848e 100644 --- a/page.ml +++ b/page.ml @@ -1,5 +1,6 @@ open XHTML.M +open ExtLib open Prelude @@ -26,13 +27,14 @@ let ul = function | [] -> p [t"?"] | h::t -> ul h t -let arg x = catch (List.find (fun a -> a#name = x)) +let arg x = catch (fun args -> let a = List.find (fun a -> a#name = x) args in a#value) type location = string (* **************************** *) let z = new Lang.ru +module Store = Storage.Fs let rec resolve self url = if url = self#url then self @@ -56,6 +58,46 @@ let render_markdown s = and render_link href = ahref href.SM.href_target [t href.SM.href_desc] and render_img i = img ~src:(uri_of_string i.SM.img_src) ~alt:i.SM.img_alt () in s >> SM.parse_text >> Simple_markup__html.to_html ~render_pre ~render_link ~render_img + +let get_index store = + match Store.get store (`S "index") with + | None -> [] + | Some s -> Marshal.from_string s 0 + +let log_exn e fmt = Printf.ksprintf print_endline fmt + +class view_comment anc = object(self) +inherit base +method children = [] +method url = "/view" +method name = z#view_comment +method render args = + let store = Store.create "comments" in + let show_index () = + ul (List.map + (fun x -> li [ahref (Printf.sprintf "%s?id=%u" self#url x) [t (string_of_int x)]]) + (List.sort ~cmp:compare (get_index store))) + in + let content = match arg "id" args with + | Some v -> + begin + try + match Store.get store (`I (int_of_string v)) with + | Some s -> render_markdown s >> div + | None -> div [h1 [t (z#no_item v)]; show_index ()] + with e -> log_exn e "view_comments(%s)" v; show_index () + end + | None -> show_index () + in + doc self#name + [ + header self [anc]; + content; + ] + +end + +exception Redirect of string class comment ctx = object(self) inherit base @@ -65,7 +107,17 @@ method name = z#add_comment method render args = let text = match arg "text" args with - | Some text -> text#value >> render_markdown >> div + | Some text -> + let store = Store.create "comments" in + let index = get_index store in + let id = match List.sort ~cmp:(flip compare) index with + | [] -> 0 + | h::_ -> h + 1 + in + (* FIXME atomicity *) + Store.add store (`S "index") (Marshal.to_string (id::index) []); + Store.add store (`I id) text; + raise (Redirect (Printf.sprintf "/view?id=%u" id)) | None -> div [p [t ""]] in doc self#name @@ -76,18 +128,17 @@ method render args = ] end -class main = -object(self) +class main = object(self) inherit base method comment = new comment self -method children = ([self#comment]:>base list) +method children = ([new comment self; new view_comment self]:>base list) method url = "/" method name = z#main_page method render args = doc self#name [ header self [self]; - ul (List.map (fun x -> li [ahref x#url [t x#name]]) [self#comment]); + ul (List.map (fun x -> li [ahref x#url [t x#name]]) self#children); ] end diff --git a/request.ml b/request.ml index cfa5885..7f7c67a 100644 --- a/request.ml +++ b/request.ml @@ -7,24 +7,30 @@ open Prelude let encode = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 () -let main (cgi:cgi) = +let main is_cgi (cgi:cgi) = let env = cgi#environment in (* let cgi_arg name = try Some (cgi#argument name)#value with _ -> None in *) let outs = cgi#out_channel#output_string in let out fmt = ksprintf outs fmt in let serve_text () = cgi#set_header ~cache:`No_cache ~content_type:"text/plain" () in let serve_html ?(status=`Ok) html = - cgi#set_header ~cache:`No_cache ~content_type:"text/html" (); - XHTML.M.output ~encode ~encoding:"utf-8" outs html + match html with + | `Redirect url -> cgi#set_redirection_header url + | `Content html -> + cgi#set_header ~cache:`No_cache ~content_type:"text/html" (); + XHTML.M.output ~encode ~encoding:"utf-8" outs html in let prefix s url = if String.starts_with url "/" then sprintf "/%s%s" (String.strip ~chars:"/" s) url else url in let render page = - let is_cgi = try env#cgi_property "REQUEST_URI" >> ignore; false with _ -> true in - let html = page#render (cgi#arguments:> list) in - if is_cgi then XHTML.M.rewrite_hrefs (prefix env#cgi_script_name) html else html + try + let html = page#render (cgi#arguments:> list) in + `Content (if is_cgi then XHTML.M.rewrite_hrefs (prefix env#cgi_script_name) html else html) + with + Page.Redirect path -> `Redirect (sprintf "%s%s" (cgi#url ~with_path_info:`None ~with_query_string:`None ()) path) in let dump_cgi () = + out "cwd : %s\n" (Unix.getcwd ()); out "\ncgi_properties\n"; List.iter (fun (k,v) -> out "%s = %s\n" k v) env#cgi_properties; out "\ninput_header_fields\n"; @@ -33,7 +39,7 @@ let main (cgi:cgi) = List.iter (fun x -> out "%s = %s\n" x#name x#value) cgi#arguments in - let path = try env#cgi_property "REQUEST_URI" with _ -> env#cgi_path_info in + let path = if is_cgi then env#cgi_path_info else env#cgi_property "REQUEST_URI" in let path = match path with "" -> "/" | s -> s in match catch (Page.resolve (Page.main:>Page.base)) path with @@ -43,10 +49,14 @@ let main (cgi:cgi) = | "/dump" -> serve_text (); dump_cgi () | _ -> new Page.not_found path >> render >> serve_html ~status:`Not_found -let main (cgi:cgi) = +let main is_cgi cgi = try - main cgi; + main is_cgi (cgi:>Netcgi.cgi); cgi#out_channel#commit_work (); with - _ -> cgi#out_channel#rollback_work () + e -> + cgi#out_channel#rollback_work (); + cgi#set_header ~cache:`No_cache ~content_type:"text/plain" ~status:`Internal_server_error (); + cgi#out_channel#output_string (Printexc.to_string e); + cgi#out_channel#commit_work () -- 2.11.4.GIT