route.ml 3.88 KB
Newer Older
mud rz's avatar
initial  
mud rz committed
1 2 3 4 5 6 7
open Opium.Std
open Tyxml
(* HTML generation library *)

(** The route handlers for our app *)

(** Defines a handler that replies to GET requests at the root endpoint *)
mud rz's avatar
mud rz committed
8
let root = get "/root"
mud rz's avatar
initial  
mud rz committed
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29
    begin fun _req ->
      let res = Response.of_html Content.welcome_page in
      Lwt.return res
    end

(** Defines a handler that takes a path parameter from the route *)
let hello = get "/hello/:lang"
    begin fun req ->
      let lang = Router.param req "lang" in
      let res = Response.of_html (Content.hello_page lang) in
      Lwt.return res
    end

(** Fallback handler in case the endpoint is called without a language parameter *)
let hello_fallback = get "/hello"
    begin fun _req ->
      let res = Response.of_html (Content.basic_page Html.[p [txt "Hiya"]]) in
      Lwt.return res
    end

let get_excerpts_add = get "/excerpts/add"
mud rz's avatar
mud rz committed
30
    begin fun _req ->
mud rz's avatar
initial  
mud rz committed
31 32
      let res = Response.of_html Content.add_excerpt_page in
      Lwt.return res
mud rz's avatar
mud rz committed
33
    end
mud rz's avatar
initial  
mud rz committed
34 35 36 37 38 39 40 41 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

let respond_or_err resp = function
  | Ok v      -> Response.of_html (resp v)
  | Error err -> Response.of_html (Content.error_page err)
;;

let excerpt_of_form_data data =
  let find data key =
    let open Core in
    (* NOTE Should handle error in case of missing fields *)
    List.Assoc.find_exn ~equal:String.equal data key |> String.concat
  in
  let author  = find data "author"
  and excerpt = find data "excerpt"
  and source  = find data "source"
  and page    = match find data "page" with "" -> None | p -> Some p
  in
  Lwt.return Excerpt.{author; excerpt; source; page}
;;

let post_excerpts_add = post "/excerpts/add" begin fun req ->
    let open Lwt.Syntax in
    (* NOTE Should handle possible error arising from invalid data *)
    let* encoded = Request.to_urlencoded req in
    let* excerpt = excerpt_of_form_data encoded in
    let+ added = Db.Update.add_excerpt excerpt req in
    respond_or_err (fun () -> Content.excerpt_added_page excerpt) added
  end

let excerpts_by_author = get "/excerpts/author/:name" begin fun req ->
    let open Lwt.Syntax in
    let name = Router.param req "name" in
    let+ excerps = Db.Get.excerpts_by_author name req in
    respond_or_err Content.excerpts_listing_page excerps
  end

mud rz's avatar
mud rz committed
70 71 72 73 74 75 76 77 78 79
let get_excerpts req name =
  let open Lwt.Syntax in
  let* excerpts = Db.Get.excerpts_by_author name req in
  let excerpts = match excerpts with
    | Error e -> Error e
    | Ok xs -> 
      let x = Excerpt.{ author= "kan"; excerpt= "My excerpt"; source= "my source"; page= Some "23" } in
      let sorted = x::xs |> List.sort (fun a -> fun b -> String.compare a.Excerpt.excerpt b.excerpt) in
      Ok (sorted) in
  Lwt.return excerpts
mud rz's avatar
initial  
mud rz committed
80 81 82

let fortunes = get "/fortunes" begin fun req ->
    let open Lwt.Syntax in
mud rz's avatar
mud rz committed
83
    let* excerpts = get_excerpts req "kan" in
mud rz's avatar
initial  
mud rz committed
84
    Lwt.return (respond_or_err Content.excerpts_listing_page excerpts)
mud rz's avatar
mud rz committed
85
  end
mud rz's avatar
initial  
mud rz committed
86 87 88

let fortunes_json = get "/fortunes-json" begin fun req ->
    let open Lwt.Syntax in
mud rz's avatar
mud rz committed
89
    let* excerpts = get_excerpts req "kan" in
mud rz's avatar
initial  
mud rz committed
90
    let res = match excerpts with
mud rz's avatar
mud rz committed
91 92 93 94 95 96
      | Error e -> 
        let json = Excerpt.Response.Err.to_yojson { message= e } in
        Response.of_json json
      | Ok xs ->
        let json = Excerpt.Response.Ok.to_yojson { excerpts= xs } in
        Response.of_json json in
mud rz's avatar
initial  
mud rz committed
97
    Lwt.return res
mud rz's avatar
mud rz committed
98
  end
mud rz's avatar
initial  
mud rz committed
99

mud rz's avatar
mud rz committed
100 101 102 103 104 105 106 107 108 109 110
module Hello_world = struct
  type t =
    { hello: string
    }[@@deriving yojson]

  let hello_world = get "/" begin fun _req ->
      let res = Response.of_json (to_yojson { hello= "world" }) in
      Lwt.return res
    end
end

mud rz's avatar
initial  
mud rz committed
111 112 113 114 115 116 117
let excerpts = get "/excerpts" begin fun req ->
    let open Lwt.Syntax in
    let+ authors = Db.Get.authors req in
    respond_or_err Content.author_excerpts_page authors
  end

let routes =
mud rz's avatar
mud rz committed
118 119
  [ Hello_world.hello_world
  ; root
mud rz's avatar
initial  
mud rz committed
120 121 122 123 124 125 126 127 128 129 130 131 132
  ; hello
  ; hello_fallback
  ; excerpts
  ; get_excerpts_add
  ; post_excerpts_add
  ; excerpts_by_author
  ; excerpts
  ; fortunes
  ; fortunes_json
  ]

let add_routes app =
  Core.List.fold ~f:(fun app route -> route app) ~init:app routes