Source file ezAPIServerUtils.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
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
(**************************************************************************)
(*                                                                        *)
(*                 Copyright 2018-2023 OCamlPro                           *)
(*                                                                        *)
(*  All rights reserved. This file is distributed under the terms of the  *)
(*  GNU Lesser General Public License version 2.1, with the special       *)
(*  exception on linking described in the file LICENSE.                   *)
(*                                                                        *)
(**************************************************************************)

open EzAPI
open Lwt.Infix

module Timings = Timings
module Directory = Directory
module Answer = Answer
module Req = Req
module GMTime = GMTime
module Ip = Ip
module Cors = Cors

(** Server *)

type server_kind =
  | API of Directory.t
  | Root of string * string option

type server = {
  server_port : int;
  server_kind : server_kind;
}

(** Utils *)

let return ?code ?headers x = Lwt.return @@ Answer.return ?code ?headers x
let return_ok ?code ?headers x = Lwt.return @@ Answer.return ?code ?headers (Ok x)
let return_error ?content ?headers code = Lwt.return @@ Answer.return ~code ?headers (Error content)

(** Register Handler *)

let empty = Directory.empty

let register_res service handler dir =
  let security = Service.security service.s in
  let path = Service.path service.s in
  let handler args input =
    if !Timings.enabled then
      let t0 = (Path.get_root path args).Req.req_time in
      let add_timing_wrap b =
        let t1 = GMTime.time () in
        Timings.add_timing (EzAPI.id service) b t0 (t1-.t0) in
      Lwt.catch
        (function () ->
           handler args security input >>= fun res ->
           add_timing_wrap true;
           Lwt.return res)
        (fun exn -> add_timing_wrap true; Lwt.fail exn)
    else handler args security input in
  let service = register service in
  Directory.register_http dir service handler

let register_ws_res service ~react ~bg ?onclose ?step dir =
  let security = Service.security service.s in
  let bg r send = bg r security send in
  let react r i = react r security i in
  let service = register service in
  Directory.register_ws dir ?onclose ?step ~react ~bg service

exception Conflict of (Dir_types.Step.t list * Dir_types.conflict)

let register service handler dir =
  match register_res service handler dir with
  | Ok dir -> dir
  | Error (steps, conflict) ->
    Format.eprintf "Conflict for %s: %s@."
      (Dir_types.Step.list_to_string steps)
      (Directory.conflict_to_string conflict);
    raise (Conflict (steps, conflict))

let register_ws service ?onclose ?step ~react ~bg dir =
  match register_ws_res service ?onclose ?step ~react ~bg dir with
  | Ok dir -> dir
  | Error (steps, conflict) ->
    Format.eprintf "Conflict for %s: %s@."
      (Dir_types.Step.list_to_string steps)
      (Directory.conflict_to_string conflict);
    raise (Conflict (steps, conflict))

module Legacy = struct

  open Lwt.Infix
  open EzAPI.Legacy

  let register (service : ('a, 'b, 'c, 'd) service) handler dir =
    let handler r sec b = handler r sec b >|= fun r ->
      {Answer.code=200; body=Ok r; headers=[]} in
    register service handler dir

end

let handle ?meth ?content_type ?ws ?(allow_origin=`default) ~file ~(printf: ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a) s r path body =
  let r, body =
    if content_type = Some Url.content_type then
      Req.add_params r (Url.decode_args body), ""
    else r, body in
  let a = match s with
    | Root (root, default) ->
      file ?meth ?default root path >>= fun a ->
      Lwt.return (`http a)
    | API dir ->
      Directory.lookup ?meth ?content_type dir r path >>= function
      | Error `Not_found -> Lwt.return (`http (Answer.not_found ()))
      | Error (`Cannot_parse a) -> Lwt.return (`http (Answer.cannot_parse a))
      | Error `Method_not_allowed -> Lwt.return (`http (Answer.method_not_allowed ()))
      | Ok (`options headers) ->
        Lwt.return {Answer.code=200; body=""; headers} >|= fun a -> `http a
      | Ok `head -> Lwt.return {Answer.code=200; body=""; headers =[]} >|= fun a -> `http a
      | Ok (`http h) ->
        begin
          h body >>= function
          | Error (`destruct_exn exn) -> Lwt.return @@ Answer.destruct_exception exn
          | Error (`unsupported c) -> Lwt.return @@ Answer.unsupported_media_type c
          | Error (`handler_error s) ->
            printf "In %s: error %s" (String.concat "/" path) s >>= fun () ->
            Lwt.return @@ Answer.server_error (Failure s)
          | Error (`handler_exn exn) ->
            printf "In %s: exception %s" (String.concat "/" path) @@ Printexc.to_string exn >>= fun () ->
            Lwt.return @@ Answer.server_error exn
          | Ok a -> Lwt.return a
        end >|= fun a -> (`http a)
      | Ok (`ws (react, bg, onclose, step)) ->
        begin match ws with
          | None -> assert false
          | Some ws ->
            let body = if body = "" then None else Some body in
            ws ?onclose ?step ?body ~react ~bg r.Req.req_id
        end >|= fun ra -> `ws ra in
  a >|= function
  | `ws ra -> `ws ra
  | `http a ->
    let origin = match allow_origin with
      | `origin -> StringMap.find_opt "origin" r.Req.req_headers
      | _ -> None in
    let headers =
      Cors.merge_headers_allow_origin ?origin a.Answer.headers allow_origin @
      [ "connection", "close" ] in
    `http { a with Answer.headers }