package uspf-mirage

  1. Overview
  2. Docs
package uspf-mirage
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file uspf_mirage.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
open Lwt.Infix

external reraise : exn -> 'a = "%reraise"

let ( % ) f g = fun x -> f (g x)

module Make (Dns_client : Dns_client_mirage.S) = struct
  let eval : type a. dns:Dns_client.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.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)
end