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
open Lwt.Infix
external reraise : exn -> 'a = "%reraise"
let ( % ) f g = fun x -> f (g x)
let eval : type a.
dns:Dns_client_lwt.t -> a Uspf.t -> Uspf.Result.t option Lwt.t =
fun ~dns t ->
let rec go : type a. a Uspf.t -> a Lwt.t = function
| Request (domain_name, record, fn) ->
Dns_client_lwt.get_resource_record dns record domain_name
>>= fun resp -> go (fn resp)
| Return v -> Lwt.return v
| Tries lst -> Lwt_list.iter_p (fun fn -> go (fn ())) lst
| Map (x, fn) -> go x >|= fn
| Choose_on c -> begin
Lwt.catch (go % c.fn) @@ function
| Uspf.Result result ->
let none _ = Uspf.terminate result in
let some = Fun.id in
let fn =
match result with
| `None -> Option.fold ~none ~some c.none
| `Neutral -> Option.fold ~none ~some c.neutral
| `Fail -> Option.fold ~none ~some c.fail
| `Softfail -> Option.fold ~none ~some c.softfail
| `Temperror -> Option.fold ~none ~some c.temperror
| `Permerror -> Option.fold ~none ~some c.permerror
| `Pass m -> begin
fun () ->
match c.pass with Some pass -> pass m | None -> none ()
end in
go (fn ())
| exn -> reraise exn
end in
let fn () = go t >>= fun _ -> Lwt.return_none in
Lwt.catch fn @@ function
| Uspf.Result result -> Lwt.return_some result
| _exn -> Lwt.return_none
let get_and_check dns ctx = eval ~dns (Uspf.get_and_check ctx)