page.ml

   1
   2 open XHTML.M
   3 open ExtLib
   4
   5 open Prelude
   6
   7 let t = pcdata
   8
   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)
  12   (body x)
  13
  14 let doc heading x = document heading [] x
  15
  16 let input_text ~title ?(id="") ?(init="") () =
  17   form ~a:[a_method `Post] ~action:(uri_of_string "")
  18    (h1 [t title])
  19    [
  20      (p [textarea ~rows:20 ~cols:80 ~a:[a_name "text"] (t init)]);
  21      (p [
  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] ()
  24       ]);
  25    ]
  26
  27 let ahref s = a ~a:[a_href (uri_of_string s)]
  28
  29 let ul = function
  30   | [] -> p [t"?"]
  31   | h::t -> ul h t
  32
  33 let arg x = catch (fun args -> let a = List.find (fun a -> a#name = x) args in a#value)
  34
  35 type location = string
  36
  37 (* **************************** *)
  38
  39 let z = new Lang.ru
  40 module Store = Storage.Fs
  41
  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
  45
  46 class virtual base =
  47 object(self)
  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
  52 end
  53
  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 ()]
  57
  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
  64
  65 let get_index store =
  66   match Store.get store (`S "index") with
  67   | None -> []
  68   | Some s -> Marshal.from_string s 0
  69
  70 let log_exn e fmt = Printf.ksprintf print_endline fmt
  71
  72 class view_comment anc = object(self)
  73 inherit base
  74 method children = []
  75 method url = "/view"
  76 method name = z#view_comment
  77 method render args =
  78   let store = Store.create "comments" in
  79   let show_index () =
  80     ul (List.map
  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)))
  83   in
  84   let content = match arg "id" args with
  85   | Some v ->
  86     begin
  87     try
  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 ()
  92     end
  93   | None -> show_index ()
  94   in
  95   doc self#name
  96   [
  97     header self [anc];
  98     content;
  99   ]
 100
 101 end
 102
 103 exception Redirect of string
 104
 105 class comment ctx = object(self)
 106 inherit base
 107 method children = []
 108 method url = "/comment"
 109 method name = z#add_comment
 110 method render args =
 111   let text =
 112   match arg "text" args with
 113   | Some text ->
 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
 117     | [] -> 0
 118     | h::_ -> h + 1
 119     in
 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 ""]]
 125   in
 126   doc self#name
 127   [
 128     header self [ctx];
 129     text;
 130     input_text self#name ()
 131   ]
 132 end
 133
 134 class edit_comment ctx = object(self)
 135 inherit base
 136 method children = []
 137 method url = "/edit_comment"
 138 method name = z#edit_comment
 139 method render args =
 140   let store = Store.create "comments" in
 141   let show_index () =
 142     ul (List.map
 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)))
 145   in
 146   try
 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
 152     | None -> ());
 153     raise (Redirect (Printf.sprintf "/view?id=%u" n))
 154   | None, _ ->
 155     doc self#name
 156     [
 157       header self [ctx];
 158       show_index ()
 159     ]
 160   | Some n, None ->
 161     doc self#name
 162     [
 163       header self [ctx];
 164       input_text ~init:(Store.get store (`I (int_of_string n)) >> Option.default "") ~id:n ~title:self#name ()
 165     ]
 166   with
 167     | Redirect r -> raise (Redirect r)
 168     | e -> log_exn e "edit_comment"; doc self#name [ header self [ctx]; show_index ()]
 169 end
 170
 171 class main = object(self)
 172 inherit base
 173 method comment = new comment self
 174 method children = ([new comment self; new view_comment self; new edit_comment self]:>base list)
 175 method url = "/"
 176 method name = z#main_page
 177 method render args =
 178   doc self#name
 179   [
 180     header self [self];
 181     ul (List.map (fun x -> li [ahref x#url [t x#name]]) self#children);
 182   ]
 183 end
 184
 185 let main = new main
 186
 187 class not_found url =
 188 object(self)
 189 inherit base
 190 method url = url
 191 method children = []
 192 method name = z#not_found
 193 method render _ =
 194   doc self#name
 195   [
 196     header self [main];
 197     p [t "Url "; b [t url]; t " not found."];
 198   ]
 199
 200 end
 201