page.ml

   1
   2 open XHTML.M
   3
   4 open Prelude
   5
   6 let t = pcdata
   7
   8 let document heading extra x =
   9   html ~a:[a_xmlns `W3_org_1999_xhtml; a_xml_lang "en"]
  10   (head (title (t heading)) extra)
  11   (body x)
  12
  13 let doc heading x = document heading [] x
  14
  15 let input_text ~title () =
  16   form ~a:[a_method `Post] ~action:(uri_of_string "")
  17    (h1 [t title])
  18    [
  19      (p [textarea ~rows:20 ~cols:80 ~a:[a_name "text"] (t"")]);
  20      (p [input ~a:[a_name "submit"; a_value "Submit"; a_input_type `Submit] ()]);
  21    ]
  22
  23 let ahref s = a ~a:[a_href (uri_of_string s)]
  24
  25 let ul = function
  26   | [] -> p [t"?"]
  27   | h::t -> ul h t
  28
  29 let arg x = catch (List.find (fun a -> a#name = x))
  30
  31 type location = string
  32
  33 (* **************************** *)
  34
  35 let z = new Lang.ru
  36
  37 let rec resolve self url =
  38   if url = self#url then self
  39   else List.find (fun child -> try ignore (resolve child url); true with Not_found -> false) self#children
  40
  41 class virtual base =
  42 object(self)
  43 method virtual url : location
  44 method virtual name : string
  45 method virtual children : base list
  46 method virtual render : <name:string;value:string> list -> html
  47 end
  48
  49 let header self pages =
  50   let name x = if Oo.id x = Oo.id self then [b [t x#name]] else [t x#name] in
  51   div [p (List.map (fun p -> [ahref p#url (name p); space ()]) pages >> List.flatten); hr ()]
  52
  53 let render_markdown s =
  54   let module SM = Simple_markup in
  55   let render_pre ~kind s = t s
  56   and render_link href = ahref href.SM.href_target [t href.SM.href_desc]
  57   and render_img i = img ~src:(uri_of_string i.SM.img_src) ~alt:i.SM.img_alt () in
  58   s >> SM.parse_text >> Simple_markup__html.to_html ~render_pre ~render_link ~render_img
  59
  60 class comment ctx = object(self)
  61 inherit base
  62 method children = []
  63 method url = "/comment"
  64 method name = z#add_comment
  65 method render args =
  66   let text =
  67   match arg "text" args with
  68   | Some text -> text#value >> render_markdown >> div
  69   | None -> div [p [t ""]]
  70   in
  71   doc self#name
  72   [
  73     header self [ctx];
  74     text;
  75     input_text self#name ()
  76   ]
  77 end
  78
  79 class main =
  80 object(self)
  81 inherit base
  82 method comment = new comment self
  83 method children = ([self#comment]:>base list)
  84 method url = "/"
  85 method name = z#main_page
  86 method render args =
  87   doc self#name
  88   [
  89     header self [self];
  90     ul (List.map (fun x -> li [ahref x#url [t x#name]]) [self#comment]);
  91   ]
  92 end
  93
  94 let main = new main
  95
  96 class not_found url =
  97 object(self)
  98 inherit base
  99 method url = url
 100 method children = []
 101 method name = z#not_found
 102 method render _ =
 103   doc self#name
 104   [
 105     header self [main];
 106     p [t "Url "; b [t url]; t " not found."];
 107   ]
 108
 109 end
 110