futur.blue
objective categorical abstract machine language personal data server
1(** mock HTTP backend for testing *)
2
3open Lwt.Syntax
4
5type request =
6 { meth: [`GET | `POST]
7 ; uri: Uri.t
8 ; headers: Cohttp.Header.t
9 ; body: string option }
10
11type response =
12 { status: Cohttp.Code.status_code
13 ; headers: (string * string) list
14 ; body: string }
15
16type handler = request -> response Lwt.t
17
18let make_cohttp_response (r : response) : Hermes.Http_backend.response =
19 let resp =
20 Cohttp.Response.make ~status:r.status
21 ~headers:(Cohttp.Header.of_list r.headers)
22 ()
23 in
24 let body = Cohttp_lwt.Body.of_string r.body in
25 (resp, body)
26
27(** create a mock HTTP backend with a handler *)
28module Make (Config : sig
29 val handler : handler ref
30end) : Hermes.Http_backend.S = struct
31 let get ~headers uri =
32 let req = {meth= `GET; uri; headers; body= None} in
33 let* r = !Config.handler req in
34 Lwt.return (make_cohttp_response r)
35
36 let post ~headers ~body uri =
37 let* body_str = Cohttp_lwt.Body.to_string body in
38 let req = {meth= `POST; uri; headers; body= Some body_str} in
39 let* r = !Config.handler req in
40 Lwt.return (make_cohttp_response r)
41end
42
43(** simple response builders *)
44
45let json_response ?(status = `OK) ?(headers = []) json =
46 { status
47 ; headers= ("content-type", "application/json") :: headers
48 ; body= Yojson.Safe.to_string json }
49
50let bytes_response ?(status = `OK) ~content_type body =
51 {status; headers= [("content-type", content_type)]; body}
52
53let error_response ~status ~error ?message () =
54 let msg_field =
55 match message with Some m -> [("message", `String m)] | None -> []
56 in
57 json_response ~status (`Assoc ([("error", `String error)] @ msg_field))
58
59let empty_response ?(status = `OK) () = {status; headers= []; body= ""}
60
61(** queue-based mock, returns responses in order *)
62module Queue = struct
63 type t = {mutable responses: response list; mutable requests: request list}
64
65 let create responses = {responses; requests= []}
66
67 let handler q req =
68 q.requests <- q.requests @ [req] ;
69 match q.responses with
70 | [] ->
71 failwith "Mock_http.Queue: no more responses"
72 | r :: rest ->
73 q.responses <- rest ;
74 Lwt.return r
75
76 let get_requests q = q.requests
77
78 let clear q =
79 q.responses <- [] ;
80 q.requests <- []
81end
82
83(** pattern-matching mock, selects responses based on request *)
84module Pattern = struct
85 type rule =
86 { nsid: string option (** match NSID in path *)
87 ; meth: [`GET | `POST] option (** match method *)
88 ; response: response }
89
90 type t =
91 {rules: rule list; mutable requests: request list; default: response option}
92
93 let create ?(default = None) rules = {rules; requests= []; default}
94
95 let extract_nsid uri =
96 let path = Uri.path uri in
97 if String.length path > 6 && String.sub path 0 6 = "/xrpc/" then
98 Some (String.sub path 6 (String.length path - 6))
99 else None
100
101 let matches rule req =
102 let nsid_matches =
103 match rule.nsid with
104 | None ->
105 true
106 | Some nsid ->
107 extract_nsid req.uri = Some nsid
108 in
109 let meth_matches =
110 match rule.meth with None -> true | Some m -> req.meth = m
111 in
112 nsid_matches && meth_matches
113
114 let handler t req =
115 t.requests <- t.requests @ [req] ;
116 match List.find_opt (fun r -> matches r req) t.rules with
117 | Some rule ->
118 Lwt.return rule.response
119 | None -> (
120 match t.default with
121 | Some r ->
122 Lwt.return r
123 | None ->
124 failwith
125 ("Mock_http.Pattern: no matching rule for " ^ Uri.to_string req.uri)
126 )
127
128 let get_requests t = t.requests
129end