Source file `status.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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
open Import
include Httpaf.Status

let rec default_reason_phrase status =
  match status with
  | #Httpaf.Status.standard as status -> Httpaf.Status.default_reason_phrase status
  | `Code n when n >= 400 && n <= 599 ->
    (match Httpaf.Status.of_code n with
    | `Code 421 -> "Misdirected Request"
    | `Code 422 -> "Unprocessable Entity"
    | `Code 423 -> "Locked"
    | `Code 424 -> "Failed Dependency"
    | `Code 428 -> "Precondition Required"
    | `Code 429 -> "Too Many Requests"
    | `Code 431 -> "Request Header Fields Too Large"
    | `Code 444 -> "Connection Closed Without Response"
    | `Code 451 -> "Unavailable For Legal Reasons"
    | `Code 499 -> "Client Closed Request"
    | `Code 506 -> "Variant Also Negotiates"
    | `Code 507 -> "Insufficient Storage"
    | `Code 508 -> "Loop Detected"
    | `Code 510 -> "Not Extended"
    | `Code 511 -> "Network Authentication Required"
    | `Code _ -> "Unknown Error"
    | status -> default_reason_phrase status)
  | _ -> ""
;;

let rec long_reason_phrase status =
  match status with
  (* Client error *)
  | `Bad_request ->
    "The server cannot or will not process the request due to something that is \
     perceived to be a client error (e.g., malformed request syntax, invalid request \
     message framing, or deceptive request routing)."
  | `Unauthorized ->
    "The request has not been applied because it lacks valid authentication credentials \
     for the target resource."
  | `Payment_required -> "Reserved for future use."
  | `Forbidden -> "The server understood the request but refuses to authorize it."
  | `Not_found ->
    "The origin server did not find a current representation for the target resource or \
     is not willing to disclose that one exists."
  | `Method_not_allowed ->
    "The method received in the request-line is known by the origin server but not \
     supported by the target resource."
  | `Not_acceptable ->
    "The target resource does not have a current representation that would be acceptable \
     to the user agent, according to the proactive negotiation header fields received in \
     the request, and the server is unwilling to supply a default representation."
  | `Proxy_authentication_required ->
    "Similar to 401 Unauthorized, but it indicates that the client needs to authenticate \
     itself in order to use a proxy."
  | `Request_timeout ->
    "The server did not receive a complete request message within the time that it was \
     prepared to wait."
  | `Conflict ->
    "The request could not be completed due to a conflict with the current state of the \
     target resource. This code is used in situations where the user might be able to \
     resolve the conflict and resubmit the request."
  | `Gone ->
    "The target resource is no longer available at the origin server and that this \
     condition is likely to be permanent."
  | `Length_required ->
    "The server refuses to accept the request without a defined Content-Length."
  | `Precondition_failed ->
    "One or more conditions given in the request header fields evaluated to false when \
     tested on the server."
  | `Payload_too_large ->
    "The server is refusing to process a request because the request payload is larger \
     than the server is willing or able to process."
  | `Uri_too_long ->
    "The server is refusing to service the request because the request-target is longer \
     than the server is willing to interpret."
  | `Unsupported_media_type ->
    "The origin server is refusing to service the request because the payload is in a \
     format not supported by this method on the target resource."
  | `Range_not_satisfiable ->
    "None of the ranges in the request's Range header field overlap the current extent \
     of the selected resource or that the set of ranges requested has been rejected due \
     to invalid ranges or an excessive request of small or overlapping ranges."
  | `Expectation_failed ->
    "The expectation given in the request's Expect header field could not be met by at \
     least one of the inbound servers."
  | `I_m_a_teapot ->
    "Any attempt to brew coffee with a teapot should result in the error code \"418 I'm \
     a teapot\". The resulting entity body MAY be short and stout."
  | `Enhance_your_calm ->
    "The user has sent too many requests in a given amount of time (\"rate limiting\")."
  | `Upgrade_required ->
    "The server refuses to perform the request using the current protocol but might be \
     willing to do so after the client upgrades to a different protocol."
  | `Code 421 ->
    "The request was directed at a server that is not able to produce a response. This \
     can be sent by a server that is not configured to produce responses for the \
     combination of scheme and authority that are included in the request URI."
  | `Code 422 ->
    "The server understands the content type of the request entity (hence a 415 \
     Unsupported Media Type status code is inappropriate), and the syntax of the request \
     entity is correct (thus a 400 Bad Request status code is inappropriate) but was \
     unable to process the contained instructions."
  | `Code 423 -> "The source or destination resource of a method is locked."
  | `Code 424 ->
    "The method could not be performed on the resource because the requested action \
     depended on another action and that action failed."
  | `Code 428 -> "The origin server requires the request to be conditional."
  | `Code 429 ->
    "The user has sent too many requests in a given amount of time (\"rate limiting\")."
  | `Code 431 ->
    "The server is unwilling to process the request because its header fields are too \
     large. The request MAY be resubmitted after reducing the size of the request header \
     fields."
  | `Code 451 ->
    "The server is denying access to the resource as a consequence of a legal demand."
  (* Server error *)
  | `Internal_server_error ->
    "The server encountered an unexpected condition that prevented it from fulfilling \
     the request."
  | `Not_implemented ->
    "The server does not support the functionality required to fulfill the request."
  | `Bad_gateway ->
    "The server, while acting as a gateway or proxy, received an invalid response from \
     an inbound server it accessed while attempting to fulfill the request."
  | `Service_unavailable ->
    "The server is currently unable to handle the request due to a temporary overload or \
     scheduled maintenance, which will likely be alleviated after some delay."
  | `Gateway_timeout ->
    "The server, while acting as a gateway or proxy, did not receive a timely response \
     from an upstream server it needed to access in order to complete the request."
  | `Http_version_not_supported ->
    "The server does not support, or refuses to support, the major version of HTTP that \
     was used in the request message."
  | `Code 506 ->
    "The server has an internal configuration error: the chosen variant resource is \
     configured to engage in transparent content negotiation itself, and is therefore \
     not a proper end point in the negotiation process."
  | `Code 507 ->
    "The method could not be performed on the resource because the server is unable to \
     store the representation needed to successfully complete the request."
  | `Code 508 ->
    "The server terminated an operation because it encountered an infinite loop while \
     processing a request with \"Depth: infinity\". This status indicates that the \
     entire operation failed."
  | `Code 510 ->
    "The policy for accessing the resource has not been met in the request. The server \
     should send back all the information necessary for the client to issue an extended \
     request."
  | `Code 511 -> "The client needs to authenticate to gain network access."
  | `Code n when n >= 400 && n <= 599 ->
    (match Httpaf.Status.of_code n with
    | `Code _ -> "The response returned an non-standard HTTP error code."
    | status -> long_reason_phrase status)
  | _ -> ""
;;

let sexp_of_t status =
  let open Sexp_conv in
  sexp_of_int (to_code status)
;;

let pp fmt t = Sexp.pp_hum fmt (sexp_of_t t)
let pp_hum fmt t = Format.fprintf fmt "%s" (to_string t)