content.ml 3.15 KB
Newer Older
mud rz's avatar
initial  
mud rz committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14
open Core
open Tyxml

(** A <head> component shared by all pages *)
let default_head =
  let open Html in
  head
    (title (txt "OCaml Webapp Tutorial"))
    [ meta ~a:[a_charset "UTF-8"] ()
    ; link ~rel:[`Stylesheet] ~href:"/static/style.css" () ]

(** The basic page layout, emitted as an [`Html string] which Opium can use as a
    response *)
let basic_page content =
mud rz's avatar
mud rz committed
15 16 17
  (*   let raw_html = *)
  let open Html in
  html default_head (body content)
mud rz's avatar
initial  
mud rz committed
18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40

(** Short hand for link formatting *)
let hyper_link name addr = Html.(a ~a:[a_href addr] [txt name])

let welcome_page =
  basic_page
    Html.[ h1 [ txt "OCaml Webapp Tutorial" ]
         ; h2 [ txt "Hello" ]
         ; ul (List.map ~f:(fun x -> li [x])
                 [ hyper_link "hiya" "/hello"
                 ; hyper_link "中文" "/hello/中文"
                 ; hyper_link "Deutsch" "/hello/Deutsch"
                 ; hyper_link "English" "/hello/English"
                 ])
         ; h2 [ txt "Excerpts" ]
         ; ul (List.map ~f:(fun x -> li [x])
                 [ hyper_link "Add Excerpt" "/excerpts/add"
                 ; hyper_link "Excerpts" "/excerpts"
                 ])
         ]

let hello_page lang =
  let greeting = match lang with
mud rz's avatar
mud rz committed
41
    | "中文"  -> "你好,世界!"
mud rz's avatar
initial  
mud rz committed
42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102
    | "Deutsch" -> "Hallo, Welt!"
    | "English" -> "Hello, World!"
    | _         -> "Language not supported :(\nYou can add a language via PR to https://gitlab.com/shonfeder/ocaml_webapp"
  in
  basic_page Html.[p [txt greeting]]

let add_excerpt_page =
  let txt_input name =
    Html.[ label ~a:[a_label_for name] [txt (String.capitalize name)]
         ; input ~a:[a_input_type `Text; a_name name] () ]
  in
  let excerpt_input =
    let name = "excerpt" in
    Html.[ label ~a:[a_label_for name] [txt (String.capitalize name)]
         ; textarea ~a:[a_name name] (txt "") ]
  in
  let submit =
    Html.[input ~a:[ a_input_type `Submit; a_value "Submit"] () ]
  in
  basic_page
    Html.[ form ~a:[a_method `Post; a_action "/excerpts/add"]
             (List.map ~f:p
                [ txt_input "author"
                ; excerpt_input
                ; txt_input "source"
                ; txt_input "page"
                ; submit
                ])]

let excerpt_elt (e : Excerpt.t) =
  let page = match e.page with
    | None -> ""
    | Some p -> Printf.sprintf ", %s" p
  in
  Html.( blockquote
           ~a:[a_class ["excerpt"]]
           [ p [txt e.excerpt]
           ; p [txt (Printf.sprintf "-- %s (%s%s)" e.author e.source page)]])

let excerpt_added_page (e : Excerpt.t) =
  basic_page
    Html.[ p [txt ("Added the following excerpt: ")]
         ; excerpt_elt e ]

let excerpts_listing_page (es : Excerpt.t list) =
  basic_page
    Html.(h1 [txt "Excerpts"] ::
          List.map ~f:excerpt_elt es)

let author_excerpts_link author =
  hyper_link author (Printf.sprintf "/excerpts/author/%s" author)

let author_excerpts_page authors =
  basic_page
    Html.[ h1 [txt "Authors with excerpts"]
         ; ul (List.map ~f:(fun a -> li [author_excerpts_link a]) authors)
         ]

let error_page err =
  basic_page
    Html.[ p [txt (Printf.sprintf "Oh no! Something went wrong: %s" err)] ]