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
open EzAPI
open Lwt.Infix

module StringMap = Map.Make(String)
module Timings = Timings
module Directory = Directory
module Answer = Answer
module Req = Req
module File = File
module GMTime = GMTime
module Ip = Ip

(** 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 = Answer.return ?code ?headers x
let return_ok ?code ?headers x = Answer.return ?code ?headers (Ok x)
let return_error ?content ?headers code = Answer.return ~code ?headers (Error content)

let verbose = match Sys.getenv_opt "EZAPISERVER" with
  | None -> ref 0
  | Some s -> match int_of_string_opt s with
    | None -> ref 1
    | Some i -> ref i

let set_verbose i = verbose := i

let pp_time () =
  GMTime.(date_of_tm @@ Unix.gmtime @@ time ())

let debug ?(v=0) fmt =
  if !verbose > v then EzDebug.printf fmt
  else Printf.ifprintf () fmt

let debugf ?(v=0) f =
  if !verbose > v then f ()

(** 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 =
    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) 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 (Directory.Step.t list * Directory.conflict)

let register service handler dir =
  match register_res service handler dir with
  | Ok dir -> dir
  | Error e -> raise (Conflict e)

let register_ws service ?onclose ?step ~react ~bg dir =
  match register_ws_res service ?onclose ?step ~react ~bg dir with
  | Ok dir -> dir
  | Error e -> raise (Conflict e)

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 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
  match s with
  | Root (root, default) -> File.reply ?meth root ?default path >|= fun a -> `http a
  | API dir ->
    Directory.lookup ?meth ?content_type dir r path >>= function
    | Error `Not_found -> Answer.not_found () >|= fun a -> `http a
    | Error (`Cannot_parse a) -> Answer.cannot_parse a >|= fun a -> `http a
    | Error `Method_not_allowed -> Answer.method_not_allowed () >|= fun a -> `http a
    | 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 (`cannot_destruct a) -> Answer.cannot_destruct a
        | Error (`unexpected_field f) -> Answer.unexpected_field f
        | Error (`unsupported c) -> Answer.unsupported_media_type c
        | Error (`handler_error s) ->
          EzDebug.printf "In %s: error %s" (String.concat "/" path) s;
          Answer.server_error (Failure s)
        | Error (`handler_exn exn) ->
          EzDebug.printf "In %s: exception %s" (String.concat "/" path) @@ Printexc.to_string exn;
          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 -> ws ?onclose ?step ~react ~bg r.Req.req_id
      end >|= fun ra -> `ws ra

let access_control_headers = [
  "access-control-allow-origin", "*";
  "access-control-allow-headers", "accept, content-type" ]