Source file web_json.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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
let log_src = Logs.Src.create "sihl.middleware.jsonparser"

module Logs = (val Logs.src_log log_src : Logs.LOG)

let key : Yojson.Safe.t Opium.Context.key =
  Opium.Context.Key.create
    ( "json"
    , fun json -> json |> Yojson.Safe.to_string |> Sexplib.Std.sexp_of_string )
;;

exception Json_body_not_found

let find req =
  try Opium.Context.find_exn key req.Opium.Request.env with
  | _ ->
    Logs.err (fun m -> m "No JSON body found");
    Logs.info (fun m ->
        m "Have you applied the JSON parser middleware for this route?");
    raise Json_body_not_found
;;

let find_opt req =
  try Some (find req) with
  | _ -> None
;;

let set token req =
  let env = req.Opium.Request.env in
  let env = Opium.Context.add key token env in
  { req with env }
;;

let middleware =
  let open Lwt.Syntax in
  let filter handler req =
    match req.Opium.Request.meth with
    (* While GET requests can have bodies, they don't have any meaning and can
       be ignored. Forms only support POST and GET as action methods. *)
    | `POST ->
      let content_type =
        try
          req
          |> Opium.Request.header "Content-Type"
          |> Option.map (String.split_on_char ';')
          |> Option.map List.hd
        with
        | _ -> None
      in
      (match content_type with
      | Some "application/json" ->
        let* json_body = Opium.Request.to_json req in
        (match json_body with
        | Some json ->
          let req = set json req in
          handler req
        | None ->
          let response_body =
            Format.sprintf {|"{"errors": ["Invalid JSON provided"]"}"|}
          in
          Opium.Response.of_plain_text response_body
          |> Opium.Response.set_status `Bad_request
          |> Lwt.return)
      | _ -> handler req)
    | _ -> handler req
  in
  Rock.Middleware.create ~name:"jsonparser" ~filter
;;