Source file catch.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
(* This file is part of Dream, released under the MIT license. See LICENSE.md
   for details, or visit https://github.com/aantron/dream.

   Copyright 2021 Anton Bachin *)



module Message = Dream_pure.Message
module Status = Dream_pure.Status



type error = {
  condition : [
    | `Response of Message.response
    | `String of string
    | `Exn of exn
  ];
  layer : [
    | `App
    | `HTTP
    | `HTTP2
    | `TLS
    | `WebSocket
  ];
  caused_by : [
    | `Server
    | `Client
  ];
  request : Message.request option;
  response : Message.response option;
  client : string option;
  severity : Log.log_level;
  will_send_response : bool;
}

type error_handler = error -> Message.response option Message.promise

(* This error handler actually *is* a middleware, but it is just one pathway for
   reaching the centralized error handler provided by the user, so it is built
   into the framework. *)

(* TODO The option return value thing is pretty awkward. *)
let catch error_handler next_handler request =

  Lwt.try_bind

    (fun () ->
      next_handler request)

    (fun response ->
      let status = Message.status response in

      (* TODO Overfull hbox. *)
      if Status.is_client_error status || Status.is_server_error status then begin
        let caused_by, severity =
          if Status.is_client_error status then
            `Client, `Warning
          else
            `Server, `Error
        in

        let error = {
          condition = `Response response;
          layer = `App;
          caused_by;
          request = Some request;
          response = Some response;
          client = Some (Helpers.client request);
          severity = severity;
          will_send_response = true;
        } in

        error_handler error
      end
      else
        Lwt.return response)

    (* This exception handler is partially redundant, in that the HTTP-level
       handlers will also catch exceptions. However, this handler is able to
       capture more relevant context. We leave the HTTP-level handlers for truly
       severe protocol-level errors and integration mistakes. *)
    (fun exn ->
      let error = {
        condition = `Exn exn;
        layer = `App;
        caused_by = `Server;
        request = Some request;
        response = None;
        client = Some (Helpers.client request);
        severity = `Error;
        will_send_response = true;
      } in

      error_handler error)