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 () =
  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"")]);
  21      (p [input ~a:[a_name "submit"; a_value "Submit"; a_input_type `Submit] ()]);
  22    ]
  23
  24 let ahref s = a ~a:[a_href (uri_of_string s)]
  25
  26 let ul = function
  27   | [] -> p [t"?"]
  28   | h::t -> ul h t
  29
  30 let arg x = catch (fun args -> let a = List.find (fun a -> a#name = x) args in a#value)
  31
  32 type location = string
  33
  34 (* **************************** *)
  35
  36 let z = new Lang.ru
  37 module Store = Storage.Fs
  38
  39 let rec resolve self url =
  40   if url = self#url then self
  41   else List.find (fun child -> try ignore (resolve child url); true with Not_found -> false) self#children
  42
  43 class virtual base =
  44 object(self)
  45 method virtual url : location
  46 method virtual name : string
  47 method virtual children : base list
  48 method virtual render : <name:string;value:string> list -> html
  49 end
  50
  51 let header self pages =
  52   let name x = if Oo.id x = Oo.id self then [b [t x#name]] else [t x#name] in
  53   div [p (List.map (fun p -> [ahref p#url (name p); space ()]) pages >> List.flatten); hr ()]
  54
  55 let render_markdown s =
  56   let module SM = Simple_markup in
  57   let render_pre ~kind s = t s
  58   and render_link href = ahref href.SM.href_target [t href.SM.href_desc]
  59   and render_img i = img ~src:(uri_of_string i.SM.img_src) ~alt:i.SM.img_alt () in
  60   s >> SM.parse_text >> Simple_markup__html.to_html ~render_pre ~render_link ~render_img
  61
  62 let get_index store =
  63   match Store.get store (`S "index") with
  64   | None -> []
  65   | Some s -> Marshal.from_string s 0
  66
  67 let log_exn e fmt = Printf.ksprintf print_endline fmt
  68
  69 class view_comment anc = object(self)
  70 inherit base
  71 method children = []
  72 method url = "/view"
  73 method name = z#view_comment
  74 method render args =
  75   let store = Store.create "comments" in
  76   let show_index () =
  77     ul (List.map
  78       (fun x -> li [ahref (Printf.sprintf "%s?id=%u" self#url x) [t (string_of_int x)]])
  79       (List.sort ~cmp:compare (get_index store)))
  80   in
  81   let content = match arg "id" args with
  82   | Some v ->
  83     begin
  84     try
  85       match Store.get store (`I (int_of_string v)) with
  86       | Some s -> render_markdown s >> div
  87       | None -> div [h1 [t (z#no_item v)]; show_index ()]
  88     with e -> log_exn e "view_comments(%s)" v; show_index ()
  89     end
  90   | None -> show_index ()
  91   in
  92   doc self#name
  93   [
  94     header self [anc];
  95     content;
  96   ]
  97
  98 end
  99
 100 exception Redirect of string
 101
 102 class comment ctx = object(self)
 103 inherit base
 104 method children = []
 105 method url = "/comment"
 106 method name = z#add_comment
 107 method render args =
 108   let text =
 109   match arg "text" args with
 110   | Some text ->
 111     let store = Store.create "comments" in
 112     let index = get_index store in
 113     let id = match List.sort ~cmp:(flip compare) index with
 114     | [] -> 0
 115     | h::_ -> h + 1
 116     in
 117     (* FIXME atomicity *)
 118     Store.add store (`S "index") (Marshal.to_string (id::index) []);
 119     Store.add store (`I id) text;
 120     raise (Redirect (Printf.sprintf "/view?id=%u" id))
 121   | None -> div [p [t ""]]
 122   in
 123   doc self#name
 124   [
 125     header self [ctx];
 126     text;
 127     input_text self#name ()
 128   ]
 129 end
 130
 131 class main = object(self)
 132 inherit base
 133 method comment = new comment self
 134 method children = ([new comment self; new view_comment self]:>base list)
 135 method url = "/"
 136 method name = z#main_page
 137 method render args =
 138   doc self#name
 139   [
 140     header self [self];
 141     ul (List.map (fun x -> li [ahref x#url [t x#name]]) self#children);
 142   ]
 143 end
 144
 145 let main = new main
 146
 147 class not_found url =
 148 object(self)
 149 inherit base
 150 method url = url
 151 method children = []
 152 method name = z#not_found
 153 method render _ =
 154   doc self#name
 155   [
 156     header self [main];
 157     p [t "Url "; b [t url]; t " not found."];
 158   ]
 159
 160 end
 161