This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
11
unikernel/duniverse/dune_/otherlibs/dune-rpc/dune
Normal file
11
unikernel/duniverse/dune_/otherlibs/dune-rpc/dune
Normal file
|
|
@ -0,0 +1,11 @@
|
|||
(library
|
||||
(name dune_rpc)
|
||||
(public_name dune-rpc)
|
||||
(synopsis "dune rpc client and protocol")
|
||||
(libraries
|
||||
stdune
|
||||
csexp
|
||||
xdg
|
||||
ordering
|
||||
pp
|
||||
(re_export dune_rpc_private)))
|
||||
1
unikernel/duniverse/dune_/otherlibs/dune-rpc/dune_rpc.ml
Normal file
1
unikernel/duniverse/dune_/otherlibs/dune-rpc/dune_rpc.ml
Normal file
|
|
@ -0,0 +1 @@
|
|||
module V1 = V1
|
||||
523
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/conv.ml
Normal file
523
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/conv.ml
Normal file
|
|
@ -0,0 +1,523 @@
|
|||
open Import
|
||||
|
||||
(* Mini clone of Dune_lang.Decoder. Main advantage is that it forbids all the
|
||||
crazy stuff and is automatically bi-directional *)
|
||||
|
||||
(* TODO error handling is complete crap for now.
|
||||
|
||||
This should be unified with [Dune_lang.Decoder] eventually. *)
|
||||
|
||||
type error =
|
||||
| Parse_error of
|
||||
{ message : string
|
||||
; payload : (string * Sexp.t) list
|
||||
}
|
||||
| Version_error of
|
||||
{ since : int * int
|
||||
; until : (int * int) option
|
||||
; message : string
|
||||
; payload : (string * Sexp.t) list
|
||||
}
|
||||
|
||||
let dyn_of_error =
|
||||
let open Dyn in
|
||||
function
|
||||
| Version_error { message; payload; until; since } ->
|
||||
record
|
||||
[ "message", string message
|
||||
; "payload", list (pair string Sexp.to_dyn) payload
|
||||
; "until", option (pair int int) until
|
||||
; "since", (pair int int) since
|
||||
]
|
||||
| Parse_error { message; payload } ->
|
||||
record
|
||||
[ "message", string message; "payload", list (pair string Sexp.to_dyn) payload ]
|
||||
;;
|
||||
|
||||
exception Of_sexp of error
|
||||
|
||||
let raise_of_sexp ?(payload = []) message =
|
||||
raise (Of_sexp (Parse_error { message; payload }))
|
||||
;;
|
||||
|
||||
let raise_version_error ?until ?(payload = []) ~since message =
|
||||
raise (Of_sexp (Version_error { since; until; message; payload }))
|
||||
;;
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| Of_sexp (Parse_error { message; payload }) ->
|
||||
Some (message ^ " " ^ Sexp.to_string (Sexp.record payload))
|
||||
| _ -> None)
|
||||
;;
|
||||
|
||||
module Fields = struct
|
||||
type t = Unparsed of Sexp.t String.Map.t
|
||||
|
||||
let check_empty (Unparsed s) =
|
||||
if not (String.Map.is_empty s)
|
||||
then (
|
||||
let payload =
|
||||
[ ( "unparsed"
|
||||
, Sexp.List
|
||||
(String.Map.to_list s
|
||||
|> List.map ~f:(fun (k, v) -> Sexp.List [ Sexp.Atom k; v ])) )
|
||||
]
|
||||
in
|
||||
raise_of_sexp ~payload "unexpected fields")
|
||||
;;
|
||||
|
||||
let empty = Unparsed String.Map.empty
|
||||
|
||||
let merge (Unparsed a) (Unparsed b) =
|
||||
Unparsed
|
||||
(String.Map.union a b ~f:(fun _ _ _ ->
|
||||
(* field names are guaranteed to be different at construction time in
|
||||
[Both] *)
|
||||
assert false))
|
||||
;;
|
||||
|
||||
let of_field name sexp = Unparsed (String.Map.singleton name sexp)
|
||||
|
||||
let of_sexp (x : Sexp.t) =
|
||||
match x with
|
||||
| Atom _ -> raise_of_sexp "Unexpected atom"
|
||||
| List x ->
|
||||
(match
|
||||
String.Map.of_list_map x ~f:(function
|
||||
| List [ Atom s; v ] -> s, v
|
||||
| _ -> raise_of_sexp "unable to read field")
|
||||
with
|
||||
| Error (s, _, _) -> raise_of_sexp "duplicate fields" ~payload:[ "field", Atom s ]
|
||||
| Ok s -> Unparsed s)
|
||||
;;
|
||||
|
||||
let optional (Unparsed t) name =
|
||||
match String.Map.find t name with
|
||||
| None -> None, Unparsed t
|
||||
| Some v -> Some v, Unparsed (String.Map.remove t name)
|
||||
;;
|
||||
|
||||
let required t name =
|
||||
let r, t = optional t name in
|
||||
match r with
|
||||
| Some s -> s, t
|
||||
| None -> raise_of_sexp "missing required field" ~payload:[ "name", Atom name ]
|
||||
;;
|
||||
|
||||
let to_sexp (Unparsed t) : Sexp.t =
|
||||
List (String.Map.to_list t |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; v ]))
|
||||
;;
|
||||
end
|
||||
|
||||
type values = Sexp.t
|
||||
type fields = Fields.t
|
||||
|
||||
type version =
|
||||
{ since : int * int
|
||||
; until : (int * int) option
|
||||
}
|
||||
|
||||
type ('a, 'kind) t =
|
||||
| String : (string, values) t
|
||||
| Int : (int, values) t
|
||||
| Float : (float, values) t
|
||||
| Unit : (unit, values) t
|
||||
| Char : (char, values) t
|
||||
| Iso : ('a, 'kind) t * ('a -> 'b) * ('b -> 'a) -> ('b, 'kind) t
|
||||
| Iso_result : ('a, 'kind) t * ('a -> ('b, exn) result) * ('b -> 'a) -> ('b, 'kind) t
|
||||
| Version : ('a, 'kind) t * version -> ('a, 'kind) t
|
||||
| Both :
|
||||
(* Invariant: field names must be different *)
|
||||
('a, fields) t
|
||||
* ('b, fields) t
|
||||
-> ('a * 'b, fields) t
|
||||
| Sexp : (Sexp.t, values) t
|
||||
| List : ('a, values) t -> ('a list, values) t
|
||||
| Field : string * 'a field -> ('a, fields) t
|
||||
| Enum : (string * 'a) list -> ('a, values) t
|
||||
| Sum : 'a econstr list * ('a -> case) -> ('a, values) t
|
||||
| Pair : ('a, values) t * ('b, values) t -> ('a * 'b, values) t
|
||||
| Triple : ('a, values) t * ('b, values) t * ('c, values) t -> ('a * 'b * 'c, values) t
|
||||
| Fdecl : int * ('a, 'k) t Fdecl.t -> ('a, 'k) t
|
||||
| Either :
|
||||
(* Invariant: field names must be different *)
|
||||
('a, fields) t
|
||||
* ('b, fields) t
|
||||
-> (('a, 'b) Either.t, fields) t
|
||||
| Record : ('a, fields) t -> ('a, values) t
|
||||
|
||||
and ('a, 'arg) constr =
|
||||
{ (* TODO allow constructors without an argument *)
|
||||
name : string
|
||||
; arg : ('arg, values) t
|
||||
; inj : 'arg -> 'a
|
||||
}
|
||||
|
||||
and 'a econstr = Constr : ('a, 'arg) constr -> 'a econstr
|
||||
and case = Case : 'arg * ('a, 'arg) constr -> case
|
||||
|
||||
and 'a field =
|
||||
| Required : ('a, values) t -> 'a field
|
||||
| Optional : ('a, values) t -> 'a option field
|
||||
|
||||
and 'k ret =
|
||||
| Values : values ret
|
||||
| Fields : Fields.t -> fields ret
|
||||
|
||||
type 'a value = ('a, values) t
|
||||
|
||||
let case a c = Case (a, c)
|
||||
let constr name arg inj = { name; arg; inj }
|
||||
let econstr c = Constr c
|
||||
let both x y = Both (x, y)
|
||||
let list x = List x
|
||||
let sum x y = Sum (x, y)
|
||||
let pair x y = Pair (x, y)
|
||||
let triple x y z = Triple (x, y, z)
|
||||
|
||||
let discard_values ((a, x) : _ * values ret) =
|
||||
match (x : values ret) with
|
||||
| Values -> a
|
||||
;;
|
||||
|
||||
let string = String
|
||||
let int = Int
|
||||
let float = Float
|
||||
let unit = Unit
|
||||
|
||||
let option x =
|
||||
let none = constr "None" unit (fun () -> None) in
|
||||
let some = constr "Some" x (fun x -> Some x) in
|
||||
sum
|
||||
[ econstr none; econstr some ]
|
||||
(function
|
||||
| None -> case () none
|
||||
| Some s -> case s some)
|
||||
;;
|
||||
|
||||
let char = Char
|
||||
|
||||
let sexp_for_digest t =
|
||||
let rec iter : type a b. int list -> (a, b) t -> Sexp.t =
|
||||
fun ids -> function
|
||||
| String -> Atom "String"
|
||||
| Int -> Atom "Int"
|
||||
| Float -> Atom "Float"
|
||||
| Unit -> Atom "Unit"
|
||||
| Char -> Atom "Char"
|
||||
| Iso (t, _, _) -> List [ Atom "Iso"; iter ids t ]
|
||||
| Iso_result (t, _, _) -> List [ Atom "Iso_result"; iter ids t ]
|
||||
| Version (t, { since = a, b; until }) ->
|
||||
let items : Sexp.t list =
|
||||
[ Atom "Version"
|
||||
; iter ids t
|
||||
; List [ Atom "since"; Atom (Int.to_string a); Atom (Int.to_string b) ]
|
||||
]
|
||||
in
|
||||
let items =
|
||||
match until with
|
||||
| None -> items
|
||||
| Some (a, b) ->
|
||||
items
|
||||
@ [ List [ Atom "until"; Atom (Int.to_string a); Atom (Int.to_string b) ] ]
|
||||
in
|
||||
List items
|
||||
| Both (a, b) -> List [ Atom "Both"; iter ids a; iter ids b ]
|
||||
| Sexp -> Atom "Sexp"
|
||||
| List t -> List [ Atom "List"; iter ids t ]
|
||||
| Field (name, field) ->
|
||||
let field : Sexp.t =
|
||||
match field with
|
||||
| Required t -> List [ Atom "Required"; iter ids t ]
|
||||
| Optional t -> List [ Atom "Optional"; iter ids t ]
|
||||
in
|
||||
List [ Atom "Field"; Atom name; field ]
|
||||
| Enum cases ->
|
||||
List (Atom "Enum" :: List.map cases ~f:(fun (name, _) : Sexp.t -> Atom name))
|
||||
| Sum (constrs, _) ->
|
||||
List
|
||||
(Atom "Sum"
|
||||
:: List.map constrs ~f:(fun (Constr { name; arg; inj = _ }) : Sexp.t ->
|
||||
List [ Atom name; iter ids arg ]))
|
||||
| Pair (a, b) -> List [ Atom "Pair"; iter ids a; iter ids b ]
|
||||
| Triple (a, b, c) -> List [ Atom "Triple"; iter ids a; iter ids b; iter ids c ]
|
||||
| Fdecl (id, fdecl) ->
|
||||
(* Although the id is represented as an auto-incrementing integer, we
|
||||
find De Bruijn indices to put in the digest so that equivalent
|
||||
structures produce the same digest. *)
|
||||
(match List.findi ids ~f:(Int.equal id) with
|
||||
| Some (_, index) -> List [ Atom "Recurse"; Atom (Int.to_string index) ]
|
||||
| None -> List [ Atom "Fixpoint"; iter (id :: ids) (Fdecl.get fdecl) ])
|
||||
| Either (a, b) -> List [ Atom "Either"; iter ids a; iter ids b ]
|
||||
| Record t -> List [ Atom "Record"; iter ids t ]
|
||||
in
|
||||
iter [] t
|
||||
;;
|
||||
|
||||
let to_sexp : 'a. ('a, values) t -> 'a -> Sexp.t =
|
||||
fun t a ->
|
||||
let rec loop : type a k. (a, k) t -> a -> k =
|
||||
fun t a ->
|
||||
match t with
|
||||
| String -> Atom a
|
||||
| Int -> Atom (Int.to_string a)
|
||||
| Float -> Atom (Float.to_string a)
|
||||
| Unit -> List []
|
||||
| Char -> Atom (String.make 1 a)
|
||||
| Sexp -> a
|
||||
| Version (t, _) -> loop t a
|
||||
| Fdecl (_, t) -> loop (Fdecl.get t) a
|
||||
| List t -> List (List.map a ~f:(loop t))
|
||||
| Pair (x, y) ->
|
||||
let a, b = a in
|
||||
List [ loop x a; loop y b ]
|
||||
| Triple (x, y, z) ->
|
||||
let a, b, c = a in
|
||||
List [ loop x a; loop y b; loop z c ]
|
||||
| Record r ->
|
||||
let fields = loop r a in
|
||||
Fields.to_sexp fields
|
||||
| Field (name, spec) ->
|
||||
(match spec with
|
||||
| Required t -> Fields.of_field name (loop t a)
|
||||
| Optional t ->
|
||||
(match a with
|
||||
| None -> Fields.empty
|
||||
| Some a -> Fields.of_field name (loop t a)))
|
||||
| Iso_result (t, _, from) -> loop t (from a)
|
||||
| Iso (t, _, from) -> loop t (from a)
|
||||
| Both (x, y) ->
|
||||
let x = loop x (fst a) in
|
||||
let y = loop y (snd a) in
|
||||
Fields.merge x y
|
||||
| Either (x, y) ->
|
||||
(match a with
|
||||
| Left a -> loop x a
|
||||
| Right a -> loop y a)
|
||||
| Sum (_, constr) ->
|
||||
let (Case (a, constr)) = constr a in
|
||||
let arg = loop constr.arg a in
|
||||
Sexp.List [ Atom constr.name; arg ]
|
||||
| Enum choices ->
|
||||
(match
|
||||
List.find_map choices ~f:(fun (s, a') ->
|
||||
if Poly.equal a a' then Some s else None)
|
||||
with
|
||||
| Some v -> Atom v
|
||||
| None ->
|
||||
let open Dyn in
|
||||
Code_error.raise
|
||||
"enum does not include this value"
|
||||
[ "valid values", list (fun (x, _) -> string x) choices ])
|
||||
in
|
||||
loop t a
|
||||
;;
|
||||
|
||||
let check_version ~version ~since ~until _ctx =
|
||||
if
|
||||
version < since
|
||||
||
|
||||
match until with
|
||||
| None -> false
|
||||
| Some until -> version > until
|
||||
then raise_version_error ?until ~since "invalid version"
|
||||
;;
|
||||
|
||||
let of_sexp : 'a. ('a, values) t -> version:int * int -> Sexp.t -> 'a =
|
||||
fun t ~version sexp ->
|
||||
let rec loop : type a k. (a, k) t -> k -> a * k ret =
|
||||
fun (type a k) (t : (a, k) t) (ctx : k) : (a * k ret) ->
|
||||
match t with
|
||||
| String ->
|
||||
(match ctx with
|
||||
| Atom s -> s, Values
|
||||
| List _ as list ->
|
||||
raise_of_sexp ~payload:[ "list", list ] "string: expected atom. received list")
|
||||
| Int ->
|
||||
(match ctx with
|
||||
| List _ as list ->
|
||||
raise_of_sexp ~payload:[ "list", list ] "int: expected atom. received list"
|
||||
| Atom s ->
|
||||
(match Int.of_string s with
|
||||
| None -> raise_of_sexp "unable to read int"
|
||||
| Some i -> i, Values))
|
||||
| Float ->
|
||||
(match ctx with
|
||||
| List _ as list ->
|
||||
raise_of_sexp ~payload:[ "list", list ] "float: expected atom. received list"
|
||||
| Atom s ->
|
||||
(match Float.of_string_opt s with
|
||||
| None -> raise_of_sexp "unable to read float"
|
||||
| Some i -> i, Values))
|
||||
| Unit ->
|
||||
(match ctx with
|
||||
| List [] -> (), Values
|
||||
| _ -> raise_of_sexp "expected empty list")
|
||||
| Char ->
|
||||
(match ctx with
|
||||
| Atom s ->
|
||||
if String.length s = 1
|
||||
then s.[0], Values
|
||||
else raise_of_sexp "expected only a single character"
|
||||
| List _ -> raise_of_sexp "expected a string of length 1")
|
||||
| Sexp -> ctx, Values
|
||||
| Version (t, { since; until }) ->
|
||||
check_version ~version ~since ~until ctx;
|
||||
loop t ctx
|
||||
| Fdecl (_, t) -> loop (Fdecl.get t) ctx
|
||||
| List t ->
|
||||
(match ctx with
|
||||
| List xs -> List.map xs ~f:(fun x -> discard_values (loop t x)), Values
|
||||
| Atom _ -> raise_of_sexp "expected list")
|
||||
| Pair (x, y) ->
|
||||
(match ctx with
|
||||
| List [ a; b ] ->
|
||||
let a, Values = loop x a in
|
||||
let b, Values = loop y b in
|
||||
(a, b), Values
|
||||
| _ -> raise_of_sexp "expected field entry")
|
||||
| Triple (x, y, z) ->
|
||||
(match ctx with
|
||||
| List [ a; b; c ] ->
|
||||
let a, Values = loop x a in
|
||||
let b, Values = loop y b in
|
||||
let c, Values = loop z c in
|
||||
(a, b, c), Values
|
||||
| _ -> raise_of_sexp "expected field entry")
|
||||
| Record (r : (a, fields) t) ->
|
||||
let (fields : Fields.t) = Fields.of_sexp ctx in
|
||||
let a, Fields f = loop r fields in
|
||||
Fields.check_empty f;
|
||||
a, Values
|
||||
| Field (name, spec) ->
|
||||
(match spec with
|
||||
| Required v ->
|
||||
let field, rest = Fields.required ctx name in
|
||||
let t, Values = loop v field in
|
||||
t, Fields rest
|
||||
| Optional v ->
|
||||
let field, rest = Fields.optional ctx name in
|
||||
let t =
|
||||
match field with
|
||||
| None -> None
|
||||
| Some f ->
|
||||
let a, Values = loop v f in
|
||||
Some a
|
||||
in
|
||||
t, Fields rest)
|
||||
| Either (x, y) ->
|
||||
(try
|
||||
(* TODO share computation somehow *)
|
||||
let a, x = loop x ctx in
|
||||
Left a, x
|
||||
with
|
||||
| Of_sexp _ ->
|
||||
let a, y = loop y ctx in
|
||||
Right a, y)
|
||||
| Iso (t, f, _) ->
|
||||
let a, k = loop t ctx in
|
||||
f a, k
|
||||
| Iso_result (t, f, _) ->
|
||||
let a, k = loop t ctx in
|
||||
(match f a with
|
||||
| Error exn -> raise exn
|
||||
| Ok a -> a, k)
|
||||
| Both (x, y) ->
|
||||
let a, Fields k = loop x ctx in
|
||||
let b, k = loop y k in
|
||||
(a, b), k
|
||||
| Sum (constrs, _) ->
|
||||
(match ctx with
|
||||
| List [ Atom head; args ] ->
|
||||
(match
|
||||
List.find_map constrs ~f:(fun (Constr c) ->
|
||||
if head = c.name
|
||||
then
|
||||
Some
|
||||
(let a, k = loop c.arg args in
|
||||
c.inj a, k)
|
||||
else None)
|
||||
with
|
||||
| None -> raise_of_sexp "invalid constructor name"
|
||||
| Some p -> p)
|
||||
| _ -> raise_of_sexp "expected constructor")
|
||||
| Enum choices ->
|
||||
(match ctx with
|
||||
| List _ -> raise_of_sexp "expected list"
|
||||
| Atom a ->
|
||||
(match List.assoc choices a with
|
||||
| None -> raise_of_sexp "unable to read enum"
|
||||
| Some s -> s, Values))
|
||||
in
|
||||
discard_values (loop t sexp)
|
||||
;;
|
||||
|
||||
let of_sexp conv ~version sexp =
|
||||
match of_sexp conv ~version sexp with
|
||||
| s -> Ok s
|
||||
| exception Of_sexp e -> Error e
|
||||
;;
|
||||
|
||||
let record r = Record r
|
||||
let either x y = Either (x, y)
|
||||
let iso a t f = Iso (a, t, f)
|
||||
let iso_result a t f = Iso_result (a, t, f)
|
||||
let version ?until t ~since = Version (t, { until; since })
|
||||
let field name spec = Field (name, spec)
|
||||
let enum choices = Enum choices
|
||||
|
||||
let three a b c =
|
||||
iso (Both (a, Both (b, c))) (fun (x, (y, z)) -> x, y, z) (fun (x, y, z) -> x, (y, z))
|
||||
;;
|
||||
|
||||
let four a b c d =
|
||||
iso
|
||||
(both (both a b) (both c d))
|
||||
(fun ((w, x), (y, z)) -> w, x, y, z)
|
||||
(fun (w, x, y, z) -> (w, x), (y, z))
|
||||
;;
|
||||
|
||||
let five a b c d e =
|
||||
iso
|
||||
(both (both a b) (three c d e))
|
||||
(fun ((a, b), (c, d, e)) -> a, b, c, d, e)
|
||||
(fun (a, b, c, d, e) -> (a, b), (c, d, e))
|
||||
;;
|
||||
|
||||
let six a b c d e f =
|
||||
iso
|
||||
(both (three a b c) (three d e f))
|
||||
(fun ((a, b, c), (d, e, f)) -> a, b, c, d, e, f)
|
||||
(fun (a, b, c, d, e, f) -> (a, b, c), (d, e, f))
|
||||
;;
|
||||
|
||||
let seven a b c d e f g =
|
||||
iso
|
||||
(both (three a b c) (four d e f g))
|
||||
(fun ((a, b, c), (d, e, f, g)) -> a, b, c, d, e, f, g)
|
||||
(fun (a, b, c, d, e, f, g) -> (a, b, c), (d, e, f, g))
|
||||
;;
|
||||
|
||||
let eight a b c d e f g h =
|
||||
iso
|
||||
(both (four a b c d) (four e f g h))
|
||||
(fun ((a, b, c, d), (e, f, g, h)) -> a, b, c, d, e, f, g, h)
|
||||
(fun (a, b, c, d, e, f, g, h) -> (a, b, c, d), (e, f, g, h))
|
||||
;;
|
||||
|
||||
let sexp = Sexp
|
||||
let required x = Required x
|
||||
let optional x = Optional x
|
||||
let fdecl_id = ref 0
|
||||
|
||||
let fixpoint f =
|
||||
let fdecl = Fdecl.create Dyn.opaque in
|
||||
let id = !fdecl_id in
|
||||
incr fdecl_id;
|
||||
let result = Fdecl (id, fdecl) in
|
||||
Fdecl.set fdecl (f result);
|
||||
result
|
||||
;;
|
||||
|
||||
let error e = raise (Of_sexp e)
|
||||
138
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/conv.mli
Normal file
138
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/conv.mli
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
(** Bidirectional parsing of canonical s-expressions *)
|
||||
|
||||
open Import
|
||||
|
||||
type ('a, 'k) t
|
||||
type values
|
||||
type 'a value = ('a, values) t
|
||||
|
||||
val sexp : (Sexp.t, values) t
|
||||
val int : (int, values) t
|
||||
val float : (float, values) t
|
||||
val unit : (unit, values) t
|
||||
val char : (char, values) t
|
||||
val string : (string, values) t
|
||||
val list : ('a, values) t -> ('a list, values) t
|
||||
val pair : ('a, values) t -> ('b, values) t -> ('a * 'b, values) t
|
||||
val option : ('a, values) t -> ('a option, values) t
|
||||
|
||||
val triple
|
||||
: ('a, values) t
|
||||
-> ('b, values) t
|
||||
-> ('c, values) t
|
||||
-> ('a * 'b * 'c, values) t
|
||||
|
||||
val enum : (string * 'a) list -> ('a, values) t
|
||||
|
||||
(** [iso t to_ from] creates a parser for a type ['b] out of a parser for a
|
||||
type ['a], where ['a] and ['b] are isomorphic to one another. The functions
|
||||
[to_] and [from] convert between the two types ['a] and ['b]. A typical
|
||||
approach for parsing record types is to convert them to/from tuples (via the
|
||||
[three], [four], etc. combinators) which can be parsed with [record], and
|
||||
then use [iso] to convert the parser for a tuple type into a parser for the
|
||||
original record type. *)
|
||||
val iso : ('a, 'k) t -> ('a -> 'b) -> ('b -> 'a) -> ('b, 'k) t
|
||||
|
||||
val iso_result : ('a, 'k) t -> ('a -> ('b, exn) result) -> ('b -> 'a) -> ('b, 'k) t
|
||||
val version : ?until:int * int -> ('a, 'k) t -> since:int * int -> ('a, 'k) t
|
||||
|
||||
(** {2 parsing records} *)
|
||||
|
||||
type fields
|
||||
type 'a field
|
||||
|
||||
val required : ('a, values) t -> 'a field
|
||||
val optional : ('a, values) t -> 'a option field
|
||||
val field : string -> 'a field -> ('a, fields) t
|
||||
val both : ('a, fields) t -> ('b, fields) t -> ('a * 'b, fields) t
|
||||
val three : ('a, fields) t -> ('b, fields) t -> ('c, fields) t -> ('a * 'b * 'c, fields) t
|
||||
|
||||
val four
|
||||
: ('a, fields) t
|
||||
-> ('b, fields) t
|
||||
-> ('c, fields) t
|
||||
-> ('d, fields) t
|
||||
-> ('a * 'b * 'c * 'd, fields) t
|
||||
|
||||
val five
|
||||
: ('a, fields) t
|
||||
-> ('b, fields) t
|
||||
-> ('c, fields) t
|
||||
-> ('d, fields) t
|
||||
-> ('e, fields) t
|
||||
-> ('a * 'b * 'c * 'd * 'e, fields) t
|
||||
|
||||
val six
|
||||
: ('a, fields) t
|
||||
-> ('b, fields) t
|
||||
-> ('c, fields) t
|
||||
-> ('d, fields) t
|
||||
-> ('e, fields) t
|
||||
-> ('f, fields) t
|
||||
-> ('a * 'b * 'c * 'd * 'e * 'f, fields) t
|
||||
|
||||
val seven
|
||||
: ('a, fields) t
|
||||
-> ('b, fields) t
|
||||
-> ('c, fields) t
|
||||
-> ('d, fields) t
|
||||
-> ('e, fields) t
|
||||
-> ('f, fields) t
|
||||
-> ('g, fields) t
|
||||
-> ('a * 'b * 'c * 'd * 'e * 'f * 'g, fields) t
|
||||
|
||||
val eight
|
||||
: ('a, fields) t
|
||||
-> ('b, fields) t
|
||||
-> ('c, fields) t
|
||||
-> ('d, fields) t
|
||||
-> ('e, fields) t
|
||||
-> ('f, fields) t
|
||||
-> ('g, fields) t
|
||||
-> ('h, fields) t
|
||||
-> ('a * 'b * 'c * 'd * 'e * 'f * 'g * 'h, fields) t
|
||||
|
||||
val record : ('a, fields) t -> ('a, values) t
|
||||
val either : ('a, fields) t -> ('b, fields) t -> (('a, 'b) Either.t, fields) t
|
||||
|
||||
(** {2 parsing sums} *)
|
||||
|
||||
type ('a, 'arg) constr
|
||||
|
||||
val constr : string -> ('arg, values) t -> ('arg -> 'a) -> ('a, 'arg) constr
|
||||
|
||||
type case
|
||||
|
||||
val case : 'arg -> ('a, 'arg) constr -> case
|
||||
|
||||
type 'a econstr
|
||||
|
||||
val econstr : ('a, 'arg) constr -> 'a econstr
|
||||
val sum : 'a econstr list -> ('a -> case) -> ('a, values) t
|
||||
|
||||
(** {2 conversion from/to} *)
|
||||
type error =
|
||||
| Parse_error of
|
||||
{ message : string
|
||||
; payload : (string * Sexp.t) list
|
||||
}
|
||||
| Version_error of
|
||||
{ since : int * int
|
||||
; until : (int * int) option
|
||||
; message : string
|
||||
; payload : (string * Sexp.t) list
|
||||
}
|
||||
|
||||
val error : error -> 'a
|
||||
val dyn_of_error : error -> Dyn.t
|
||||
val to_sexp : ('a, values) t -> 'a -> Sexp.t
|
||||
val of_sexp : ('a, values) t -> version:int * int -> Sexp.t -> ('a, error) result
|
||||
|
||||
(** [fixpoint f] is a helper for creating parsers of recursive data structures
|
||||
such as ASTs. [f] is a function which returns a parser for a single node in
|
||||
the hierarchy, and [f] is passed a parser which it can use for parsing
|
||||
children of the current node. [fixpoint f] then returns a parser for the
|
||||
recursive data structure. *)
|
||||
val fixpoint : (('a, 'k) t -> ('a, 'k) t) -> ('a, 'k) t
|
||||
|
||||
val sexp_for_digest : ('a, 'k) t -> Sexp.t
|
||||
|
|
@ -0,0 +1,21 @@
|
|||
(* Taken from the ocaml-obus project with permission from Jeremie Dimino
|
||||
<jeremie@dimino.org> *)
|
||||
|
||||
(** Type of an address *)
|
||||
type t =
|
||||
{ name : string (** The transport name *)
|
||||
; args : (string * string) list (** Arguments of the address *)
|
||||
}
|
||||
|
||||
(** {6 To/from string conversion} *)
|
||||
|
||||
type error =
|
||||
{ position : int
|
||||
; reason : string
|
||||
}
|
||||
|
||||
(** [of_string str] parse [str] and return the address in it. *)
|
||||
val of_string : string -> (t, error) result
|
||||
|
||||
(** [to_string addresses] return a string representation of a list of addresses *)
|
||||
val to_string : t -> string
|
||||
|
|
@ -0,0 +1,153 @@
|
|||
|
||||
{
|
||||
(*
|
||||
* Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org>
|
||||
* Licence : BSD3
|
||||
*
|
||||
* This file is a part of obus, an ocaml implementation of D-Bus.
|
||||
*)
|
||||
exception Fail of int * string
|
||||
|
||||
let pos lexbuf = lexbuf.Lexing.lex_start_p.Lexing.pos_cnum
|
||||
|
||||
let fail lexbuf fmt =
|
||||
Printf.ksprintf
|
||||
(fun msg -> raise (Fail(pos lexbuf, msg)))
|
||||
fmt
|
||||
|
||||
let decode_char ch = match ch with
|
||||
| '0'..'9' -> Char.code ch - Char.code '0'
|
||||
| 'a'..'f' -> Char.code ch - Char.code 'a' + 10
|
||||
| 'A'..'F' -> Char.code ch - Char.code 'A' + 10
|
||||
| _ -> raise (Invalid_argument "decode_char")
|
||||
|
||||
let hex_decode hex =
|
||||
if String.length hex mod 2 <> 0 then raise (Invalid_argument "OBus_util.hex_decode");
|
||||
let len = String.length hex / 2 in
|
||||
let str = Bytes.create len in
|
||||
for i = 0 to len - 1 do
|
||||
Bytes.unsafe_set str i
|
||||
(char_of_int
|
||||
((decode_char (String.unsafe_get hex (i * 2)) lsl 4) lor
|
||||
(decode_char (String.unsafe_get hex (i * 2 + 1)))))
|
||||
done;
|
||||
Bytes.unsafe_to_string str
|
||||
|
||||
type t =
|
||||
{ name : string
|
||||
; args : (string * string) list
|
||||
}
|
||||
|
||||
type error =
|
||||
{ position : int
|
||||
; reason : string
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
let name = [^ ':' ',' ';' '=']+
|
||||
|
||||
rule address = parse
|
||||
| name as name {
|
||||
check_colon lexbuf;
|
||||
let args = parameters lexbuf in
|
||||
check_eof lexbuf;
|
||||
{ name ; args }
|
||||
}
|
||||
| ":" {
|
||||
fail lexbuf "empty transport name"
|
||||
}
|
||||
| eof {
|
||||
fail lexbuf "address expected"
|
||||
}
|
||||
|
||||
and check_eof = parse
|
||||
| eof { () }
|
||||
| _ as ch { fail lexbuf "invalid character %C" ch }
|
||||
|
||||
and check_colon = parse
|
||||
| ":" { () }
|
||||
| "" { fail lexbuf "colon expected after transport name" }
|
||||
|
||||
and parameters = parse
|
||||
| name as key {
|
||||
check_equal lexbuf;
|
||||
let value = value (Buffer.create 42) lexbuf in
|
||||
if coma lexbuf then
|
||||
(key, value) :: parameters_plus lexbuf
|
||||
else
|
||||
[(key, value)]
|
||||
}
|
||||
| "=" { fail lexbuf "empty key" }
|
||||
| "" { [] }
|
||||
|
||||
and parameters_plus = parse
|
||||
| name as key {
|
||||
check_equal lexbuf;
|
||||
let value = value (Buffer.create 42) lexbuf in
|
||||
if coma lexbuf then
|
||||
(key, value) :: parameters_plus lexbuf
|
||||
else
|
||||
[(key, value)]
|
||||
}
|
||||
| "=" { fail lexbuf "empty key" }
|
||||
| "" { fail lexbuf "parameter expected" }
|
||||
|
||||
and coma = parse
|
||||
| "," { true }
|
||||
| "" { false }
|
||||
|
||||
and check_equal = parse
|
||||
| "=" { () }
|
||||
| "" { fail lexbuf "equal expected after key" }
|
||||
|
||||
and value buf = parse
|
||||
| [ '0'-'9' 'A'-'Z' 'a'-'z' '_' '-' '/' '.' '\\' ] as ch {
|
||||
Buffer.add_char buf ch;
|
||||
value buf lexbuf
|
||||
}
|
||||
| "%" {
|
||||
Buffer.add_string buf (unescape lexbuf);
|
||||
value buf lexbuf
|
||||
}
|
||||
| "" {
|
||||
Buffer.contents buf
|
||||
}
|
||||
|
||||
and unescape = parse
|
||||
| [ '0'-'9' 'a'-'f' 'A'-'F' ] [ '0'-'9' 'a'-'f' 'A'-'F' ] as str
|
||||
{ hex_decode str }
|
||||
| ""
|
||||
{ fail lexbuf "two hexdigits expected after '%%'" }
|
||||
|
||||
{
|
||||
let of_string str =
|
||||
try
|
||||
Ok (address (Lexing.from_string str))
|
||||
with Fail(position, reason) ->
|
||||
Error { position ; reason }
|
||||
|
||||
let to_string { name ; args } =
|
||||
let buf = Buffer.create 42 in
|
||||
let escape = String.iter begin fun ch -> match ch with
|
||||
| '0'..'9' | 'A'..'Z' | 'a'..'z'
|
||||
| '_' | '-' | '/' | '.' | '\\' ->
|
||||
Buffer.add_char buf ch
|
||||
| _ ->
|
||||
Printf.bprintf buf "%%%02x" (Char.code ch)
|
||||
end in
|
||||
let concat ch f = function
|
||||
| [] -> ()
|
||||
| x :: l -> f x; List.iter (fun x -> Buffer.add_char buf ch; f x) l
|
||||
in
|
||||
Buffer.add_string buf name;
|
||||
Buffer.add_char buf ':';
|
||||
concat ','
|
||||
(fun (k, v) ->
|
||||
Buffer.add_string buf k;
|
||||
Buffer.add_char buf '=';
|
||||
escape v)
|
||||
args;
|
||||
Buffer.contents buf
|
||||
|
||||
}
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
open Import
|
||||
open Exported_types
|
||||
|
||||
module Related = struct
|
||||
type t =
|
||||
{ message : unit Pp.t
|
||||
; loc : Loc.t
|
||||
}
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let loc = field "loc" (required Loc.sexp) in
|
||||
let message = field "message" (required sexp_pp_unit) in
|
||||
let to_ (loc, message) = { loc; message } in
|
||||
let from { loc; message } = loc, message in
|
||||
iso (record (both loc message)) to_ from
|
||||
;;
|
||||
|
||||
let to_diagnostic_related t : Diagnostic.Related.t =
|
||||
{ message = t.message |> Pp.map_tags ~f:(fun _ -> User_message.Style.Details)
|
||||
; loc = t.loc
|
||||
}
|
||||
;;
|
||||
|
||||
let of_diagnostic_related (t : Diagnostic.Related.t) =
|
||||
{ message = t.message |> Pp.map_tags ~f:(fun _ -> ()); loc = t.loc }
|
||||
;;
|
||||
end
|
||||
|
||||
type t =
|
||||
{ targets : Target.t list
|
||||
; id : Diagnostic.Id.t
|
||||
; message : unit Pp.t
|
||||
; loc : Loc.t option
|
||||
; severity : Diagnostic.severity option
|
||||
; promotion : Diagnostic.Promotion.t list
|
||||
; directory : string option
|
||||
; related : Related.t list
|
||||
}
|
||||
|
||||
let sexp_severity =
|
||||
let open Conv in
|
||||
enum [ "error", Diagnostic.Error; "warning", Warning ]
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { targets; message; loc; severity; promotion; directory; id; related } =
|
||||
targets, message, loc, severity, promotion, directory, id, related
|
||||
in
|
||||
let to_ (targets, message, loc, severity, promotion, directory, id, related) =
|
||||
{ targets; message; loc; severity; promotion; directory; id; related }
|
||||
in
|
||||
let loc = field "loc" (optional Loc.sexp) in
|
||||
let message = field "message" (required sexp_pp_unit) in
|
||||
let targets = field "targets" (required (list Target.sexp)) in
|
||||
let severity = field "severity" (optional sexp_severity) in
|
||||
let directory = field "directory" (optional string) in
|
||||
let promotion = field "promotion" (required (list Diagnostic.Promotion.sexp)) in
|
||||
let id = field "id" (required Diagnostic.Id.sexp) in
|
||||
let related = field "related" (required (list Related.sexp)) in
|
||||
iso
|
||||
(record (eight targets message loc severity promotion directory id related))
|
||||
to_
|
||||
from
|
||||
;;
|
||||
|
||||
let to_diagnostic t : Diagnostic.t =
|
||||
{ targets = t.targets
|
||||
; message = t.message |> Pp.map_tags ~f:(fun _ -> User_message.Style.Details)
|
||||
; loc = t.loc
|
||||
; severity = t.severity
|
||||
; promotion = t.promotion
|
||||
; directory = t.directory
|
||||
; id = t.id
|
||||
; related = t.related |> List.map ~f:Related.to_diagnostic_related
|
||||
}
|
||||
;;
|
||||
|
||||
let of_diagnostic (t : Diagnostic.t) =
|
||||
{ targets = t.targets
|
||||
; message = t.message |> Pp.map_tags ~f:(fun _ -> ())
|
||||
; loc = t.loc
|
||||
; severity = t.severity
|
||||
; promotion = t.promotion
|
||||
; directory = t.directory
|
||||
; id = t.id
|
||||
; related = t.related |> List.map ~f:Related.of_diagnostic_related
|
||||
}
|
||||
;;
|
||||
|
||||
module Event = struct
|
||||
type nonrec t =
|
||||
| Add of t
|
||||
| Remove of t
|
||||
|
||||
let sexp =
|
||||
let diagnostic = sexp in
|
||||
let open Conv in
|
||||
let add = constr "Add" diagnostic (fun a -> Add a) in
|
||||
let remove = constr "Remove" diagnostic (fun a -> Remove a) in
|
||||
sum
|
||||
[ econstr add; econstr remove ]
|
||||
(function
|
||||
| Add t -> case t add
|
||||
| Remove t -> case t remove)
|
||||
;;
|
||||
|
||||
let to_event : t -> Diagnostic.Event.t = function
|
||||
| Add t -> Add (to_diagnostic t)
|
||||
| Remove t -> Remove (to_diagnostic t)
|
||||
;;
|
||||
|
||||
let of_event : Diagnostic.Event.t -> t = function
|
||||
| Add t -> Add (of_diagnostic t)
|
||||
| Remove t -> Remove (of_diagnostic t)
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
(** V1 of the diagnostics module. *)
|
||||
|
||||
module Related : sig
|
||||
type t
|
||||
|
||||
val to_diagnostic_related : t -> Exported_types.Diagnostic.Related.t
|
||||
val of_diagnostic_related : Exported_types.Diagnostic.Related.t -> t
|
||||
end
|
||||
|
||||
type t
|
||||
|
||||
val sexp : (t, Conv.values) Conv.t
|
||||
val to_diagnostic : t -> Exported_types.Diagnostic.t
|
||||
val of_diagnostic : Exported_types.Diagnostic.t -> t
|
||||
|
||||
module Event : sig
|
||||
type t
|
||||
|
||||
val sexp : (t, Conv.values) Conv.t
|
||||
val to_event : t -> Exported_types.Diagnostic.Event.t
|
||||
val of_event : Exported_types.Diagnostic.Event.t -> t
|
||||
end
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
(library
|
||||
(name dune_rpc_private)
|
||||
(public_name dune-rpc.private)
|
||||
(libraries csexp dyn ocamlc_loc ordering pp stdune unix xdg)
|
||||
(synopsis "for internal use only"))
|
||||
|
||||
(ocamllex dbus_address)
|
||||
|
|
@ -0,0 +1,751 @@
|
|||
open Import
|
||||
module Conv = Conv
|
||||
module Versioned = Versioned
|
||||
module Menu = Menu
|
||||
module Procedures = Procedures
|
||||
module Where = Where
|
||||
module Registry = Registry
|
||||
include Types
|
||||
include Exported_types
|
||||
module Version_error = Versioned.Version_error
|
||||
module Decl = Decl
|
||||
module Sub = Sub
|
||||
|
||||
module type Fiber = Fiber_intf.S
|
||||
|
||||
module Public = struct
|
||||
module Request = struct
|
||||
type ('a, 'b) t = ('a, 'b) Decl.Request.witness
|
||||
|
||||
let ping = Procedures.Public.ping.decl
|
||||
let diagnostics = Procedures.Public.diagnostics.decl
|
||||
let format_dune_file = Procedures.Public.format_dune_file.decl
|
||||
let promote = Procedures.Public.promote.decl
|
||||
let promote_many = Procedures.Public.promote_many.decl
|
||||
let build_dir = Procedures.Public.build_dir.decl
|
||||
end
|
||||
|
||||
module Notification = struct
|
||||
type 'a t = 'a Decl.Notification.witness
|
||||
|
||||
let shutdown = Procedures.Public.shutdown.decl
|
||||
end
|
||||
|
||||
module Sub = struct
|
||||
type 'a t = 'a Sub.t
|
||||
|
||||
let diagnostic = Sub.of_procedure Procedures.Poll.diagnostic
|
||||
let progress = Sub.of_procedure Procedures.Poll.progress
|
||||
let running_jobs = Sub.of_procedure Procedures.Poll.running_jobs
|
||||
end
|
||||
end
|
||||
|
||||
module Server_notifications = struct
|
||||
let abort = Procedures.Server_side.abort.decl
|
||||
let log = Procedures.Server_side.log.decl
|
||||
end
|
||||
|
||||
module Client = struct
|
||||
module type S = sig
|
||||
type t
|
||||
type 'a fiber
|
||||
type chan
|
||||
|
||||
module Versioned : sig
|
||||
type ('a, 'b) request = ('a, 'b) Versioned.Staged.request
|
||||
type 'a notification = 'a Versioned.Staged.notification
|
||||
|
||||
val prepare_request
|
||||
: t
|
||||
-> ('a, 'b) Decl.Request.witness
|
||||
-> (('a, 'b) request, Version_error.t) result fiber
|
||||
|
||||
val prepare_notification
|
||||
: t
|
||||
-> 'a Decl.Notification.witness
|
||||
-> ('a notification, Version_error.t) result fiber
|
||||
end
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit fiber
|
||||
val disconnected : t -> unit fiber
|
||||
|
||||
module Stream : sig
|
||||
type 'a t
|
||||
|
||||
val cancel : _ t -> unit fiber
|
||||
val next : 'a t -> 'a option fiber
|
||||
end
|
||||
|
||||
val poll : ?id:Id.t -> t -> 'a Sub.t -> ('a Stream.t, Version_error.t) result fiber
|
||||
|
||||
module Batch : sig
|
||||
type client := t
|
||||
type t
|
||||
|
||||
val create : client -> t
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit
|
||||
val submit : t -> unit fiber
|
||||
end
|
||||
|
||||
module Handler : sig
|
||||
type t
|
||||
|
||||
val create
|
||||
: ?log:(Message.t -> unit fiber)
|
||||
-> ?abort:(Message.t -> unit fiber)
|
||||
-> unit
|
||||
-> t
|
||||
end
|
||||
|
||||
type proc =
|
||||
| Request : ('a, 'b) Decl.request -> proc
|
||||
| Notification : 'a Decl.notification -> proc
|
||||
| Poll : 'a Procedures.Poll.t -> proc
|
||||
| Handle_request : ('a, 'b) Decl.request * ('a -> 'b fiber) -> proc
|
||||
|
||||
val connect_with_menu
|
||||
: ?handler:Handler.t
|
||||
-> private_menu:proc list
|
||||
-> chan
|
||||
-> Initialize.Request.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
|
||||
val connect
|
||||
: ?handler:Handler.t
|
||||
-> chan
|
||||
-> Initialize.Request.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
end
|
||||
|
||||
module Make
|
||||
(Fiber : Fiber_intf.S)
|
||||
(Chan : sig
|
||||
type t
|
||||
|
||||
val write : t -> Sexp.t list option -> unit Fiber.t
|
||||
val read : t -> Sexp.t option Fiber.t
|
||||
end) =
|
||||
struct
|
||||
open Fiber.O
|
||||
module V = Versioned.Make (Fiber)
|
||||
|
||||
module Chan = struct
|
||||
type t =
|
||||
{ read : unit -> Sexp.t option Fiber.t
|
||||
; write : Sexp.t list option -> unit Fiber.t
|
||||
; closed_read : bool
|
||||
; mutable closed_write : bool
|
||||
; disconnected : unit Fiber.Ivar.t
|
||||
}
|
||||
|
||||
let of_chan c =
|
||||
let disconnected = Fiber.Ivar.create () in
|
||||
let read () =
|
||||
let* result = Chan.read c in
|
||||
match result with
|
||||
| None ->
|
||||
let+ () = Fiber.Ivar.fill disconnected () in
|
||||
None
|
||||
| _ -> Fiber.return result
|
||||
in
|
||||
{ read
|
||||
; write = (fun s -> Chan.write c s)
|
||||
; closed_read = false
|
||||
; closed_write = false
|
||||
; disconnected
|
||||
}
|
||||
;;
|
||||
|
||||
let write t s =
|
||||
let* () = Fiber.return () in
|
||||
match s with
|
||||
| Some _ -> t.write s
|
||||
| None ->
|
||||
if t.closed_write
|
||||
then Fiber.return ()
|
||||
else (
|
||||
t.closed_write <- true;
|
||||
t.write None)
|
||||
;;
|
||||
|
||||
let read t =
|
||||
let* () = Fiber.return () in
|
||||
if t.closed_read then Fiber.return None else t.read ()
|
||||
;;
|
||||
end
|
||||
|
||||
type abort =
|
||||
| Invalid_session of Conv.error
|
||||
| Server_aborted of Message.t
|
||||
|
||||
exception Abort of abort
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| Abort error ->
|
||||
let dyn =
|
||||
match error with
|
||||
| Invalid_session e -> Dyn.variant "Invalid_session" [ Conv.dyn_of_error e ]
|
||||
| Server_aborted e ->
|
||||
Dyn.variant "Server_aborted" [ Sexp.to_dyn (Message.to_sexp_unversioned e) ]
|
||||
in
|
||||
Some (Dyn.to_string dyn)
|
||||
| _ -> None)
|
||||
;;
|
||||
|
||||
type t =
|
||||
{ chan : Chan.t
|
||||
; requests :
|
||||
( Id.t
|
||||
, [ `Cancelled
|
||||
| `Pending of
|
||||
[ `Completed of Response.t | `Connection_dead | `Cancelled ]
|
||||
Fiber.Ivar.t
|
||||
] )
|
||||
Table.t
|
||||
; initialize : Initialize.Request.t
|
||||
; mutable next_id : int
|
||||
; mutable running : bool
|
||||
; mutable handler_initialized : bool
|
||||
; (* We need this field to be an Ivar to ensure that any typed
|
||||
communications are correctly versioned. The contract of the [Fiber]
|
||||
interface ensures that this will be filled before any user code is
|
||||
run. *)
|
||||
handler : unit V.Handler.t Fiber.t
|
||||
; on_preemptive_abort : Message.t -> unit Fiber.t
|
||||
}
|
||||
|
||||
(* When the client is terminated via this function, the session is
|
||||
considered to be dead without a way to recover. *)
|
||||
let terminate t =
|
||||
let* () = Fiber.return () in
|
||||
match t.running with
|
||||
| false -> Fiber.return ()
|
||||
| true ->
|
||||
t.running <- false;
|
||||
let ivars = ref [] in
|
||||
Table.filteri_inplace t.requests ~f:(fun ~key:_ ~data:ivar ->
|
||||
ivars := ivar :: !ivars;
|
||||
false);
|
||||
let ivars () =
|
||||
Fiber.return
|
||||
(match !ivars with
|
||||
| [] -> None
|
||||
| x :: xs ->
|
||||
ivars := xs;
|
||||
Some x)
|
||||
in
|
||||
Fiber.fork_and_join_unit
|
||||
(fun () -> Chan.write t.chan None)
|
||||
(fun () ->
|
||||
Fiber.parallel_iter ivars ~f:(fun status ->
|
||||
match status with
|
||||
| `Cancelled -> Fiber.return ()
|
||||
| `Pending ivar -> Fiber.Ivar.fill ivar `Connection_dead))
|
||||
;;
|
||||
|
||||
let terminate_with_error t message info =
|
||||
Fiber.fork_and_join_unit
|
||||
(fun () -> terminate t)
|
||||
(fun () ->
|
||||
(* TODO stop using code error here. If [terminate_with_error] is
|
||||
called, it's because the other side is doing something unexpected,
|
||||
not because we have a bug *)
|
||||
Code_error.raise message info)
|
||||
;;
|
||||
|
||||
let send conn (packet : Packet.t list option) =
|
||||
let sexps = Option.map packet ~f:(List.map ~f:(Conv.to_sexp Packet.sexp)) in
|
||||
Chan.write conn.chan sexps
|
||||
;;
|
||||
|
||||
let create ~chan ~initialize ~handler ~on_preemptive_abort =
|
||||
let requests = Table.create (module Id) 16 in
|
||||
{ chan
|
||||
; requests
|
||||
; next_id = 0
|
||||
; initialize
|
||||
; running = true
|
||||
; handler_initialized = false
|
||||
; handler
|
||||
; on_preemptive_abort
|
||||
}
|
||||
;;
|
||||
|
||||
let prepare_request' conn (id, req) =
|
||||
match conn.running with
|
||||
| false ->
|
||||
let err =
|
||||
let payload =
|
||||
Sexp.record
|
||||
[ "id", Id.to_sexp id; "req", Conv.to_sexp (Conv.record Call.fields) req ]
|
||||
in
|
||||
Response.Error.create
|
||||
~payload
|
||||
~message:"request sent while connection is dead"
|
||||
~kind:Connection_dead
|
||||
()
|
||||
in
|
||||
Error err
|
||||
| true ->
|
||||
let ivar = Fiber.Ivar.create () in
|
||||
(match Table.add conn.requests id (`Pending ivar) with
|
||||
| Ok () -> ()
|
||||
| Error _ -> Code_error.raise "duplicate id" [ "id", Id.to_dyn id ]);
|
||||
Ok ivar
|
||||
;;
|
||||
|
||||
let request_untyped conn (id, req) =
|
||||
let* () = Fiber.return () in
|
||||
match prepare_request' conn (id, req) with
|
||||
| Error e -> Fiber.return (`Completed (Error e))
|
||||
| Ok ivar ->
|
||||
let* () = send conn (Some [ Request (id, req) ]) in
|
||||
Fiber.Ivar.read ivar
|
||||
;;
|
||||
|
||||
let parse_response t decode = function
|
||||
| Error e -> Fiber.return (Error e)
|
||||
| Ok res ->
|
||||
(match decode res with
|
||||
| Ok s -> Fiber.return (Ok s)
|
||||
| Error e ->
|
||||
terminate_with_error
|
||||
t
|
||||
"response not matched by decl"
|
||||
[ "e", Response.Error.to_dyn e ])
|
||||
;;
|
||||
|
||||
let gen_id t = function
|
||||
| Some id -> id
|
||||
| None ->
|
||||
let id = Sexp.List [ Atom "auto"; Atom (Int.to_string t.next_id) ] in
|
||||
t.next_id <- t.next_id + 1;
|
||||
Id.make id
|
||||
;;
|
||||
|
||||
module Versioned = struct
|
||||
type ('a, 'b) request = ('a, 'b) Versioned.Staged.request
|
||||
type 'a notification = 'a Versioned.Staged.notification
|
||||
|
||||
let prepare_request t (decl : _ Decl.Request.witness) =
|
||||
let+ handler = t.handler in
|
||||
V.Handler.prepare_request handler decl
|
||||
;;
|
||||
|
||||
let prepare_notification (type a) t (decl : a Decl.Notification.witness) =
|
||||
let+ handler = t.handler in
|
||||
V.Handler.prepare_notification handler decl
|
||||
;;
|
||||
end
|
||||
|
||||
let request t id ({ encode_req; decode_resp } : _ Versioned.request) req =
|
||||
let req = encode_req req in
|
||||
let* res = request_untyped t (id, req) in
|
||||
match res with
|
||||
| `Connection_dead -> Fiber.return `Connection_dead
|
||||
| `Cancelled -> Fiber.return `Cancelled
|
||||
| `Completed res ->
|
||||
let+ res = parse_response t decode_resp res in
|
||||
`Completed res
|
||||
;;
|
||||
|
||||
let cancel t id =
|
||||
match Table.find t.requests id with
|
||||
| None | Some `Cancelled -> Fiber.return ()
|
||||
| Some (`Pending ivar) ->
|
||||
Table.remove t.requests id;
|
||||
Fiber.Ivar.fill ivar `Cancelled
|
||||
;;
|
||||
|
||||
let make_notification
|
||||
(type a)
|
||||
t
|
||||
({ encode } : a Versioned.notification)
|
||||
(n : a)
|
||||
(k : Call.t -> 'a)
|
||||
: 'a
|
||||
=
|
||||
let call = encode n in
|
||||
match t.running with
|
||||
| true -> k call
|
||||
| false ->
|
||||
let err =
|
||||
let payload = Conv.to_sexp (Conv.record Call.fields) call in
|
||||
Response.Error.create
|
||||
~payload
|
||||
~message:"notification sent while connection is dead"
|
||||
~kind:Code_error
|
||||
()
|
||||
in
|
||||
raise (Response.Error.E err)
|
||||
;;
|
||||
|
||||
let notification (type a) t (stg : a Versioned.notification) (n : a) =
|
||||
let* () = Fiber.return () in
|
||||
make_notification t stg n (fun call -> send t (Some [ Notification call ]))
|
||||
;;
|
||||
|
||||
let disconnected t = Fiber.Ivar.read t.chan.disconnected
|
||||
|
||||
module Stream = struct
|
||||
type nonrec 'a t =
|
||||
{ poll : (Id.t, 'a option) Versioned.request
|
||||
; cancel : Id.t Versioned.notification
|
||||
; client : t
|
||||
; id : Id.t
|
||||
; mutable pending_request_id : Id.t option
|
||||
; counter : int
|
||||
; mutable active : bool
|
||||
}
|
||||
|
||||
let create sub client id =
|
||||
let+ handler = client.handler in
|
||||
let open Result.O in
|
||||
let+ poll = V.Handler.prepare_request handler (Sub.poll sub)
|
||||
and+ cancel = V.Handler.prepare_notification handler (Sub.poll_cancel sub) in
|
||||
{ poll
|
||||
; cancel
|
||||
; client
|
||||
; id
|
||||
; pending_request_id = None
|
||||
; counter = 0
|
||||
; active = true
|
||||
}
|
||||
;;
|
||||
|
||||
let check_active t =
|
||||
if not t.active
|
||||
then Code_error.raise "polling is inactive" [ "id", Id.to_dyn t.id ]
|
||||
;;
|
||||
|
||||
let next t =
|
||||
let* () = Fiber.return () in
|
||||
check_active t;
|
||||
(match t.pending_request_id with
|
||||
| Some _ ->
|
||||
Code_error.raise "Poll.next: previous Poll.next did not terminate yet" []
|
||||
| None -> ());
|
||||
let id =
|
||||
Sexp.record
|
||||
[ "poll", Id.to_sexp t.id; "i", Sexp.Atom (string_of_int t.counter) ]
|
||||
|> Id.make
|
||||
in
|
||||
t.pending_request_id <- Some id;
|
||||
let+ res = request t.client id t.poll t.id in
|
||||
t.pending_request_id <- None;
|
||||
match res with
|
||||
| `Connection_dead | `Cancelled -> None
|
||||
| `Completed (Ok res) -> res
|
||||
| `Completed (Error e) ->
|
||||
(* cwong: Should this really be a raise? *)
|
||||
raise (Response.Error.E e)
|
||||
;;
|
||||
|
||||
let cancel t =
|
||||
let* () = Fiber.return () in
|
||||
check_active t;
|
||||
t.active <- false;
|
||||
(* XXX should we add a pool to stop waiting for the notification to
|
||||
reach the server? *)
|
||||
let notify () = notification t.client t.cancel t.id in
|
||||
match t.pending_request_id with
|
||||
| None -> notify ()
|
||||
| Some id -> Fiber.fork_and_join_unit (fun () -> cancel t.client id) notify
|
||||
;;
|
||||
end
|
||||
|
||||
let no_cancel_raise_connection_dead id = function
|
||||
| `Cancelled -> assert false
|
||||
| `Completed s -> s
|
||||
| `Connection_dead ->
|
||||
let payload = Sexp.record [ "id", Id.to_sexp id ] in
|
||||
let error =
|
||||
Response.Error.create
|
||||
~kind:Connection_dead
|
||||
~payload
|
||||
~message:"connection terminated. this request will never receive a response"
|
||||
()
|
||||
in
|
||||
Error error
|
||||
;;
|
||||
|
||||
let request ?id t spec req =
|
||||
let id = gen_id t id in
|
||||
let+ res = request t id spec req in
|
||||
no_cancel_raise_connection_dead id res
|
||||
;;
|
||||
|
||||
let poll ?id client sub =
|
||||
let* () = Fiber.return () in
|
||||
let id = gen_id client id in
|
||||
Stream.create sub client id
|
||||
;;
|
||||
|
||||
module Batch = struct
|
||||
type nonrec t =
|
||||
{ client : t
|
||||
; mutable pending : Packet.t list
|
||||
}
|
||||
|
||||
let create client = { client; pending = [] }
|
||||
|
||||
let notification t n a =
|
||||
make_notification t.client n a (fun call ->
|
||||
t.pending <- Notification call :: t.pending)
|
||||
;;
|
||||
|
||||
let request
|
||||
(type a b)
|
||||
?id
|
||||
t
|
||||
({ encode_req; decode_resp } : (a, b) Versioned.request)
|
||||
(req : a)
|
||||
: (b, _) result Fiber.t
|
||||
=
|
||||
let* () = Fiber.return () in
|
||||
let id = gen_id t.client id in
|
||||
let call = encode_req req in
|
||||
let ivar = prepare_request' t.client (id, call) in
|
||||
match ivar with
|
||||
| Error e -> Fiber.return (Error e)
|
||||
| Ok ivar ->
|
||||
t.pending <- Packet.Request (id, call) :: t.pending;
|
||||
let* res = Fiber.Ivar.read ivar in
|
||||
(* currently impossible because there's no batching for polling and
|
||||
cancellation is only available for polled requests *)
|
||||
let res = no_cancel_raise_connection_dead id res in
|
||||
parse_response t.client decode_resp res
|
||||
;;
|
||||
|
||||
let submit t =
|
||||
let* () = Fiber.return () in
|
||||
let pending = List.rev t.pending in
|
||||
t.pending <- [];
|
||||
send t.client (Some pending)
|
||||
;;
|
||||
end
|
||||
|
||||
let read_packets t packets =
|
||||
let* () =
|
||||
Fiber.parallel_iter packets ~f:(function
|
||||
| Packet.Notification n ->
|
||||
if
|
||||
String.equal n.method_ Procedures.Server_side.abort.decl.method_
|
||||
&& not t.handler_initialized
|
||||
then (
|
||||
match
|
||||
Conv.of_sexp ~version:t.initialize.dune_version Message.sexp n.params
|
||||
with
|
||||
| Ok msg -> t.on_preemptive_abort msg
|
||||
| Error error ->
|
||||
terminate_with_error
|
||||
t
|
||||
"fatal: server aborted connection, but couldn't parse reason"
|
||||
[ "reason", Sexp.to_dyn n.params; "error", Conv.dyn_of_error error ])
|
||||
else
|
||||
let* handler = t.handler in
|
||||
let* result = V.Handler.handle_notification handler () n in
|
||||
(match result with
|
||||
| Error e ->
|
||||
terminate_with_error
|
||||
t
|
||||
"received bad notification from server"
|
||||
[ "error", Response.Error.to_dyn e; "notification", Call.to_dyn n ]
|
||||
| Ok () -> Fiber.return ())
|
||||
| Request (id, req) ->
|
||||
let* handler = t.handler in
|
||||
let* result = V.Handler.handle_request handler () (id, req) in
|
||||
send t (Some [ Response (id, result) ])
|
||||
| Response (id, response) ->
|
||||
(match Table.find t.requests id with
|
||||
| Some status ->
|
||||
Table.remove t.requests id;
|
||||
(match status with
|
||||
| `Pending ivar -> Fiber.Ivar.fill ivar (`Completed response)
|
||||
| `Cancelled -> Fiber.return ())
|
||||
| None ->
|
||||
terminate_with_error
|
||||
t
|
||||
"unexpected response"
|
||||
[ "id", Id.to_dyn id; "response", Response.to_dyn response ]))
|
||||
in
|
||||
terminate t
|
||||
;;
|
||||
|
||||
module Handler = struct
|
||||
type nonrec t =
|
||||
{ log : Message.t -> unit Fiber.t
|
||||
; abort : Message.t -> unit Fiber.t
|
||||
}
|
||||
|
||||
let log { Message.payload; message } =
|
||||
let+ () = Fiber.return () in
|
||||
match payload with
|
||||
| None -> Format.eprintf "%s@." message
|
||||
| Some payload -> Format.eprintf "%s: %s@." message (Sexp.to_string payload)
|
||||
;;
|
||||
|
||||
let abort m = raise (Abort (Server_aborted m))
|
||||
let default = { log; abort }
|
||||
|
||||
let create ?log ?abort () =
|
||||
let t =
|
||||
let t = default in
|
||||
match log with
|
||||
| None -> t
|
||||
| Some log -> { t with log }
|
||||
in
|
||||
let t =
|
||||
match abort with
|
||||
| None -> t
|
||||
| Some abort -> { t with abort }
|
||||
in
|
||||
t
|
||||
;;
|
||||
end
|
||||
|
||||
type proc =
|
||||
| Request : ('a, 'b) Decl.request -> proc
|
||||
| Notification : 'a Decl.notification -> proc
|
||||
| Poll : 'a Procedures.Poll.t -> proc
|
||||
| Handle_request : ('a, 'b) Decl.request * ('a -> 'b Fiber.t) -> proc
|
||||
|
||||
let setup_versioning ~private_menu ~(handler : Handler.t) =
|
||||
let module Builder = V.Builder in
|
||||
let t : unit Builder.t = Builder.create () in
|
||||
(* CR-soon cwong: It is a *huge* footgun that you have to remember to
|
||||
declare a request here, or via [private_menu], and there is no
|
||||
mechanism to warn you if you forget. The closest thing is either seeing
|
||||
that [dune rpc status] does not report the new procedure, or need to
|
||||
deal with the [Notification_error.t], which contains some good context,
|
||||
but very little to indicate this specific problem. *)
|
||||
Builder.declare_request t Procedures.Public.ping;
|
||||
Builder.declare_request t Procedures.Public.diagnostics;
|
||||
Builder.declare_request t Procedures.Poll.(poll running_jobs);
|
||||
Builder.declare_notification t Procedures.Public.shutdown;
|
||||
Builder.declare_request t Procedures.Public.format_dune_file;
|
||||
Builder.declare_request t Procedures.Public.promote;
|
||||
Builder.declare_request t Procedures.Public.promote_many;
|
||||
Builder.declare_request t Procedures.Public.build_dir;
|
||||
Builder.implement_notification t Procedures.Server_side.abort (fun () ->
|
||||
handler.abort);
|
||||
Builder.implement_notification t Procedures.Server_side.log (fun () -> handler.log);
|
||||
Builder.declare_request t Procedures.Poll.(poll diagnostic);
|
||||
Builder.declare_request t Procedures.Poll.(poll progress);
|
||||
Builder.declare_notification t Procedures.Poll.(cancel running_jobs);
|
||||
Builder.declare_notification t Procedures.Poll.(cancel diagnostic);
|
||||
Builder.declare_notification t Procedures.Poll.(cancel progress);
|
||||
List.iter private_menu ~f:(function
|
||||
| Handle_request (r, h) -> Builder.implement_request t r (fun () -> h)
|
||||
| Request r -> Builder.declare_request t r
|
||||
| Notification n -> Builder.declare_notification t n
|
||||
| Poll p ->
|
||||
Builder.declare_request t (Procedures.Poll.poll p);
|
||||
Builder.declare_notification t (Procedures.Poll.cancel p));
|
||||
t
|
||||
;;
|
||||
|
||||
let connect_raw
|
||||
chan
|
||||
(initialize : Initialize.Request.t)
|
||||
~(private_menu : proc list)
|
||||
~(handler : Handler.t)
|
||||
~f
|
||||
=
|
||||
let packets () =
|
||||
let+ read = Chan.read chan in
|
||||
Option.map read ~f:(fun sexp ->
|
||||
match Conv.of_sexp Packet.sexp ~version:initialize.dune_version sexp with
|
||||
| Error e -> raise (Abort (Invalid_session e))
|
||||
| Ok message -> message)
|
||||
in
|
||||
let builder = setup_versioning ~handler ~private_menu in
|
||||
let handler_var = Fiber.Ivar.create () in
|
||||
let client =
|
||||
let on_preemptive_abort = handler.abort in
|
||||
let handler = Fiber.Ivar.read handler_var in
|
||||
create ~initialize ~chan ~handler ~on_preemptive_abort
|
||||
in
|
||||
let run () =
|
||||
let* init =
|
||||
let id = Id.make (List [ Atom "initialize" ]) in
|
||||
let initialize = Initialize.Request.to_call initialize in
|
||||
let+ res = request_untyped client (id, initialize) in
|
||||
no_cancel_raise_connection_dead id res
|
||||
in
|
||||
match init with
|
||||
| Error e -> raise (Response.Error.E e)
|
||||
| Ok csexp ->
|
||||
let* menu =
|
||||
match
|
||||
Conv.of_sexp ~version:initialize.dune_version Initialize.Response.sexp csexp
|
||||
with
|
||||
| Error e -> raise (Abort (Invalid_session e))
|
||||
| Ok _resp ->
|
||||
let id = Id.make (List [ Atom "version menu" ]) in
|
||||
let supported_versions =
|
||||
let request =
|
||||
Version_negotiation.Request.create
|
||||
(V.Builder.registered_procedures builder)
|
||||
in
|
||||
Version_negotiation.Request.to_call request
|
||||
in
|
||||
let* resp = request_untyped client (id, supported_versions) in
|
||||
(* we don't allow cancelling negotiation *)
|
||||
(match no_cancel_raise_connection_dead id resp with
|
||||
| Error e -> raise (Response.Error.E e)
|
||||
| Ok sexp ->
|
||||
(match
|
||||
Conv.of_sexp
|
||||
~version:initialize.dune_version
|
||||
Version_negotiation.Response.sexp
|
||||
sexp
|
||||
with
|
||||
| Error e -> raise (Abort (Invalid_session e))
|
||||
| Ok (Selected methods) ->
|
||||
(match Menu.of_list methods with
|
||||
| Ok m -> Fiber.return m
|
||||
| Error (method_, a, b) ->
|
||||
terminate_with_error
|
||||
client
|
||||
"server responded with invalid version menu"
|
||||
[ ( "duplicated"
|
||||
, Dyn.Tuple [ Dyn.String method_; Dyn.Int a; Dyn.Int b ] )
|
||||
])))
|
||||
in
|
||||
let handler =
|
||||
V.Builder.to_handler builder ~menu ~session_version:(fun () ->
|
||||
client.initialize.dune_version)
|
||||
in
|
||||
client.handler_initialized <- true;
|
||||
let* () = Fiber.Ivar.fill handler_var handler in
|
||||
Fiber.finalize (fun () -> f client) ~finally:(fun () -> Chan.write chan None)
|
||||
in
|
||||
Fiber.fork_and_join_unit (fun () -> read_packets client packets) run
|
||||
;;
|
||||
|
||||
let connect_with_menu ?(handler = Handler.default) ~private_menu chan init ~f =
|
||||
connect_raw (Chan.of_chan chan) init ~handler ~private_menu ~f
|
||||
;;
|
||||
|
||||
let connect = connect_with_menu ~private_menu:[]
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,499 @@
|
|||
open Stdune
|
||||
module Conv : module type of Conv
|
||||
module Where : module type of Where
|
||||
module Registry : module type of Registry
|
||||
|
||||
module type Fiber = Fiber_intf.S
|
||||
|
||||
include module type of Exported_types
|
||||
|
||||
module Method : sig
|
||||
module Name : sig
|
||||
type t = string
|
||||
|
||||
module Map = String.Map
|
||||
module Table = String.Table
|
||||
end
|
||||
|
||||
module Version : sig
|
||||
type t = int
|
||||
|
||||
module Set = Int.Set
|
||||
module Map = Int.Map
|
||||
end
|
||||
end
|
||||
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val sexp : t Conv.value
|
||||
val to_dyn : t -> Dyn.t
|
||||
val equal : t -> t -> bool
|
||||
val hash : t -> int
|
||||
val make : Csexp.t -> t
|
||||
val to_sexp : t -> Csexp.t
|
||||
|
||||
include Comparable_intf.S with type key := t
|
||||
end
|
||||
|
||||
module Call : sig
|
||||
type t =
|
||||
{ method_ : string
|
||||
; params : Csexp.t
|
||||
}
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val create : ?params:Csexp.t -> method_:Method.Name.t -> unit -> t
|
||||
end
|
||||
|
||||
module Version_error : sig
|
||||
type t
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
val to_dyn : t -> Dyn.t
|
||||
|
||||
exception E of t
|
||||
end
|
||||
|
||||
module Request : sig
|
||||
type t = Id.t * Call.t
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
module Error : sig
|
||||
type kind =
|
||||
| Invalid_request
|
||||
| Code_error
|
||||
| Connection_dead
|
||||
|
||||
type t =
|
||||
{ payload : Csexp.t option
|
||||
; message : string
|
||||
; kind : kind
|
||||
}
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
val kind : t -> kind
|
||||
|
||||
exception E of t
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val of_conv : Conv.error -> t
|
||||
val create : ?payload:Csexp.t -> kind:kind -> message:string -> unit -> t
|
||||
end
|
||||
|
||||
type t = (Csexp.t, Error.t) result
|
||||
end
|
||||
|
||||
module Initialize : sig
|
||||
module Request : sig
|
||||
type t =
|
||||
{ dune_version : int * int
|
||||
; protocol_version : int
|
||||
; id : Id.t
|
||||
}
|
||||
|
||||
val create : id:Id.t -> t
|
||||
val dune_version : t -> int * int
|
||||
val protocol_version : t -> int
|
||||
val id : t -> Id.t
|
||||
val of_call : Call.t -> version:int * int -> (t, Response.Error.t) result
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val to_response : t -> Csexp.t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module Version_negotiation : sig
|
||||
module Request : sig
|
||||
type t = private Menu of (Method.Name.t * Method.Version.t list) list
|
||||
|
||||
val create : (Method.Name.t * Method.Version.t list) list -> t
|
||||
val sexp : t Conv.value
|
||||
val of_call : Call.t -> version:int * int -> (t, Response.Error.t) result
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
type t
|
||||
|
||||
val create : (Method.Name.t * Method.Version.t) list -> t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module Decl : sig
|
||||
module Request : sig
|
||||
type ('req, 'resp) gen
|
||||
|
||||
val make_gen
|
||||
: req:'wire_req Conv.value
|
||||
-> resp:'wire_resp Conv.value
|
||||
-> upgrade_req:('wire_req -> 'req)
|
||||
-> downgrade_req:('req -> 'wire_req)
|
||||
-> upgrade_resp:('wire_resp -> 'resp)
|
||||
-> downgrade_resp:('resp -> 'wire_resp)
|
||||
-> version:Method.Version.t
|
||||
-> ('req, 'resp) gen
|
||||
|
||||
val make_current_gen
|
||||
: req:'req Conv.value
|
||||
-> resp:'resp Conv.value
|
||||
-> version:Method.Version.t
|
||||
-> ('req, 'resp) gen
|
||||
|
||||
type ('a, 'b) t
|
||||
|
||||
val make
|
||||
: method_:Method.Name.t
|
||||
-> generations:('req, 'resp) gen list
|
||||
-> ('req, 'resp) t
|
||||
|
||||
val print_generations : ('req, 'resp) t -> unit
|
||||
|
||||
type ('a, 'b) witness
|
||||
|
||||
val witness : ('a, 'b) t -> ('a, 'b) witness
|
||||
end
|
||||
|
||||
module Notification : sig
|
||||
type 'payload gen
|
||||
|
||||
val make_gen
|
||||
: conv:'wire Conv.value
|
||||
-> upgrade:('wire -> 'model)
|
||||
-> downgrade:('model -> 'wire)
|
||||
-> version:Method.Version.t
|
||||
-> 'model gen
|
||||
|
||||
val make_current_gen : conv:'a Conv.value -> version:Method.Version.t -> 'a gen
|
||||
|
||||
type 'a t
|
||||
|
||||
val make : method_:Method.Name.t -> generations:'payload gen list -> 'payload t
|
||||
val print_generations : 'payload t -> unit
|
||||
|
||||
type 'a witness
|
||||
|
||||
val witness : 'a t -> 'a witness
|
||||
end
|
||||
|
||||
type ('a, 'b) request = ('a, 'b) Request.t
|
||||
type 'a notification = 'a Notification.t
|
||||
end
|
||||
|
||||
module Procedures : sig
|
||||
(** Procedures with generations for server impl *)
|
||||
module Public : sig
|
||||
val ping : (unit, unit) Decl.Request.t
|
||||
val diagnostics : (unit, Diagnostic.t list) Decl.Request.t
|
||||
val shutdown : unit Decl.Notification.t
|
||||
val format_dune_file : (Path.t * [ `Contents of string ], string) Decl.Request.t
|
||||
val promote : (Path.t, unit) Decl.Request.t
|
||||
|
||||
val promote_many
|
||||
: (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.Request.t
|
||||
|
||||
val build_dir : (unit, Path.t) Decl.Request.t
|
||||
end
|
||||
|
||||
module Server_side : sig
|
||||
val abort : Message.t Decl.Notification.t
|
||||
val log : Message.t Decl.Notification.t
|
||||
end
|
||||
|
||||
module Poll : sig
|
||||
type 'a t
|
||||
|
||||
val poll : 'a t -> (Id.t, 'a option) Decl.Request.t
|
||||
val cancel : 'a t -> Id.t Decl.Notification.t
|
||||
|
||||
module Name : sig
|
||||
type t
|
||||
|
||||
val make : string -> t
|
||||
val compare : t -> t -> Ordering.t
|
||||
end
|
||||
|
||||
val name : 'a t -> Name.t
|
||||
val make : Name.t -> (Id.t, 'a option) Decl.Request.gen list -> 'a t
|
||||
val progress : Progress.t t
|
||||
val diagnostic : Diagnostic.Event.t list t
|
||||
val running_jobs : Job.Event.t list t
|
||||
end
|
||||
end
|
||||
|
||||
module Sub : sig
|
||||
type 'a t
|
||||
|
||||
val of_procedure : 'a Procedures.Poll.t -> 'a t
|
||||
end
|
||||
|
||||
module Public : sig
|
||||
(** Public requests and notifications *)
|
||||
module Request : sig
|
||||
type ('a, 'b) t = ('a, 'b) Decl.Request.witness
|
||||
|
||||
val ping : (unit, unit) t
|
||||
val diagnostics : (unit, Diagnostic.t list) t
|
||||
val format_dune_file : (Path.t * [ `Contents of string ], string) t
|
||||
val promote : (Path.t, unit) t
|
||||
val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) t
|
||||
val build_dir : (unit, Path.t) t
|
||||
end
|
||||
|
||||
module Notification : sig
|
||||
type 'a t = 'a Decl.Notification.witness
|
||||
|
||||
val shutdown : unit t
|
||||
end
|
||||
|
||||
module Sub : sig
|
||||
type 'a t = 'a Sub.t
|
||||
|
||||
val diagnostic : Diagnostic.Event.t list t
|
||||
val progress : Progress.t t
|
||||
val running_jobs : Job.Event.t list t
|
||||
end
|
||||
end
|
||||
|
||||
module Packet : sig
|
||||
type t =
|
||||
| Request of Request.t
|
||||
| Response of (Id.t * Response.t)
|
||||
| Notification of Call.t
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Version : sig
|
||||
type t = int * int
|
||||
|
||||
val latest : t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Protocol : sig
|
||||
type t = int
|
||||
|
||||
val latest_version : t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Menu : sig
|
||||
type t
|
||||
|
||||
val default : t
|
||||
|
||||
(** For each method known by both local and remote, choose the highest common
|
||||
version number. Returns [None] if the resulting menu would be empty. *)
|
||||
val select_common
|
||||
: local_versions:Method.Version.Set.t Method.Name.Map.t
|
||||
-> remote_versions:(Method.Name.t * Method.Version.t list) list
|
||||
-> t option
|
||||
|
||||
val of_list
|
||||
: (Method.Name.t * Method.Version.t) list
|
||||
-> (t, Method.Name.t * Method.Version.t * Method.Version.t) result
|
||||
|
||||
val to_list : t -> (Method.Name.t * Method.Version.t) list
|
||||
val to_dyn : t -> Dyn.t
|
||||
end
|
||||
|
||||
module Versioned : sig
|
||||
module Staged : sig
|
||||
type ('req, 'resp) request =
|
||||
{ encode_req : 'req -> Call.t
|
||||
; decode_resp : Csexp.t -> ('resp, Response.Error.t) result
|
||||
}
|
||||
|
||||
type 'payload notification = { encode : 'payload -> Call.t }
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
module Handler : sig
|
||||
type 'state t
|
||||
|
||||
val handle_request : 'state t -> 'state -> Request.t -> Response.t fiber
|
||||
|
||||
val handle_notification
|
||||
: 'state t
|
||||
-> 'state
|
||||
-> Call.t
|
||||
-> (unit, Response.Error.t) result fiber
|
||||
|
||||
val prepare_request
|
||||
: 'a t
|
||||
-> ('req, 'resp) Decl.Request.witness
|
||||
-> (('req, 'resp) Staged.request, Version_error.t) result
|
||||
|
||||
val prepare_notification
|
||||
: 'a t
|
||||
-> 'payload Decl.Notification.witness
|
||||
-> ('payload Staged.notification, Version_error.t) result
|
||||
end
|
||||
|
||||
module Builder : sig
|
||||
type 'state t
|
||||
|
||||
val to_handler
|
||||
: 'state t
|
||||
-> session_version:('state -> int * int)
|
||||
-> menu:Menu.t
|
||||
-> 'state Handler.t
|
||||
|
||||
val create : unit -> 'state t
|
||||
val registered_procedures : 'a t -> (Method.Name.t * Method.Version.t list) list
|
||||
|
||||
(** A *declaration* of a procedure is a claim that this side of the
|
||||
session is able to *initiate* that procedure. Correspondingly,
|
||||
*implementing* a procedure enables you to *receive* that procedure
|
||||
(and probably do something in response).
|
||||
|
||||
Currently, attempting to both implement and declare the same procedure
|
||||
in the same builder will raise. While there is nothing fundamentally
|
||||
wrong with allowing this, it is simpler for the initial version
|
||||
negotiation to treat all method names uniformly, rather than
|
||||
specifying whether a given (set of) generation(s) is implemented or
|
||||
declared.
|
||||
|
||||
Finally, attempting to declare or implement the same generation twice
|
||||
will also raise. *)
|
||||
val declare_notification : 'state t -> 'payload Decl.notification -> unit
|
||||
|
||||
val declare_request : 'state t -> ('req, 'resp) Decl.request -> unit
|
||||
|
||||
val implement_notification
|
||||
: 'state t
|
||||
-> 'payload Decl.notification
|
||||
-> ('state -> 'payload -> unit fiber)
|
||||
-> unit
|
||||
|
||||
val implement_request
|
||||
: 'state t
|
||||
-> ('req, 'resp) Decl.request
|
||||
-> ('state -> 'req -> 'resp fiber)
|
||||
-> unit
|
||||
end
|
||||
end
|
||||
|
||||
module Make (Fiber : Fiber) : S with type 'a fiber := 'a Fiber.t
|
||||
end
|
||||
|
||||
module Client : sig
|
||||
module type S = sig
|
||||
type t
|
||||
type 'a fiber
|
||||
type chan
|
||||
|
||||
module Versioned : sig
|
||||
type ('a, 'b) request = ('a, 'b) Versioned.Staged.request
|
||||
type 'a notification = 'a Versioned.Staged.notification
|
||||
|
||||
val prepare_request
|
||||
: t
|
||||
-> ('a, 'b) Decl.Request.witness
|
||||
-> (('a, 'b) request, Version_error.t) result fiber
|
||||
|
||||
val prepare_notification
|
||||
: t
|
||||
-> 'a Decl.Notification.witness
|
||||
-> ('a notification, Version_error.t) result fiber
|
||||
end
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit fiber
|
||||
val disconnected : t -> unit fiber
|
||||
|
||||
module Stream : sig
|
||||
type 'a t
|
||||
|
||||
val cancel : _ t -> unit fiber
|
||||
val next : 'a t -> 'a option fiber
|
||||
end
|
||||
|
||||
val poll : ?id:Id.t -> t -> 'a Sub.t -> ('a Stream.t, Version_error.t) result fiber
|
||||
|
||||
module Batch : sig
|
||||
type client := t
|
||||
type t
|
||||
|
||||
val create : client -> t
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit
|
||||
val submit : t -> unit fiber
|
||||
end
|
||||
|
||||
module Handler : sig
|
||||
type t
|
||||
|
||||
val create
|
||||
: ?log:(Message.t -> unit fiber)
|
||||
-> ?abort:(Message.t -> unit fiber)
|
||||
-> unit
|
||||
-> t
|
||||
end
|
||||
|
||||
type proc =
|
||||
| Request : ('a, 'b) Decl.request -> proc
|
||||
(** The client may send the declared request *)
|
||||
| Notification : 'a Decl.notification -> proc
|
||||
(** The client may send the declared notification *)
|
||||
| Poll : 'a Procedures.Poll.t -> proc
|
||||
(** The client may start the declared polling loop *)
|
||||
| Handle_request : ('a, 'b) Decl.request * ('a -> 'b fiber) -> proc
|
||||
(** The client can handle the declared request *)
|
||||
|
||||
val connect_with_menu
|
||||
: ?handler:Handler.t
|
||||
-> private_menu:proc list
|
||||
-> chan
|
||||
-> Initialize.Request.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
|
||||
val connect
|
||||
: ?handler:Handler.t
|
||||
-> chan
|
||||
-> Initialize.Request.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
end
|
||||
|
||||
module Make
|
||||
(Fiber : Fiber)
|
||||
(Chan : sig
|
||||
type t
|
||||
|
||||
val write : t -> Csexp.t list option -> unit Fiber.t
|
||||
val read : t -> Csexp.t option Fiber.t
|
||||
end) : S with type 'a fiber := 'a Fiber.t and type chan := Chan.t
|
||||
end
|
||||
|
||||
module Server_notifications : sig
|
||||
(** Notification sent from server to client *)
|
||||
|
||||
val log : Message.t Decl.Notification.witness
|
||||
val abort : Message.t Decl.Notification.witness
|
||||
end
|
||||
|
|
@ -0,0 +1,839 @@
|
|||
open Import
|
||||
|
||||
module Loc = struct
|
||||
type t = Stdune.Lexbuf.Loc.t =
|
||||
{ start : Lexing.position
|
||||
; stop : Lexing.position
|
||||
}
|
||||
|
||||
let start t = t.start
|
||||
let stop t = t.stop
|
||||
|
||||
let pos_sexp =
|
||||
let open Conv in
|
||||
let to_ (pos_fname, pos_lnum, pos_bol, pos_cnum) =
|
||||
{ Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum }
|
||||
in
|
||||
let from { Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum } =
|
||||
pos_fname, pos_lnum, pos_bol, pos_cnum
|
||||
in
|
||||
let pos_fname = field "pos_fname" (required string) in
|
||||
let pos_lnum = field "pos_lnum" (required int) in
|
||||
let pos_bol = field "pos_bol" (required int) in
|
||||
let pos_cnum = field "pos_cnum" (required int) in
|
||||
iso (record (four pos_fname pos_lnum pos_bol pos_cnum)) to_ from
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let to_ (start, stop) = { start; stop } in
|
||||
let from { start; stop } = start, stop in
|
||||
let start = field "start" (required pos_sexp) in
|
||||
let stop = field "stop" (required pos_sexp) in
|
||||
iso (record (both start stop)) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
module Ansi_color = struct
|
||||
module RGB8 = struct
|
||||
include Stdune.Ansi_color.RGB8
|
||||
|
||||
let sexp =
|
||||
Conv.iso Conv.char Stdune.Ansi_color.RGB8.of_char Stdune.Ansi_color.RGB8.to_char
|
||||
;;
|
||||
end
|
||||
|
||||
module RGB24 = struct
|
||||
include Stdune.Ansi_color.RGB24
|
||||
|
||||
let sexp =
|
||||
Conv.iso Conv.int Stdune.Ansi_color.RGB24.of_int Stdune.Ansi_color.RGB24.to_int
|
||||
;;
|
||||
end
|
||||
|
||||
module Style = struct
|
||||
type t = Stdune.Ansi_color.Style.t
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let fg_default = constr "Fg_default" unit (fun () -> `Fg_default) in
|
||||
let fg_black = constr "Fg_black" unit (fun () -> `Fg_black) in
|
||||
let fg_red = constr "Fg_red" unit (fun () -> `Fg_red) in
|
||||
let fg_green = constr "Fg_green" unit (fun () -> `Fg_green) in
|
||||
let fg_yellow = constr "Fg_yellow" unit (fun () -> `Fg_yellow) in
|
||||
let fg_blue = constr "Fg_blue" unit (fun () -> `Fg_blue) in
|
||||
let fg_magenta = constr "Fg_magenta" unit (fun () -> `Fg_magenta) in
|
||||
let fg_cyan = constr "Fg_cyan" unit (fun () -> `Fg_cyan) in
|
||||
let fg_white = constr "Fg_white" unit (fun () -> `Fg_white) in
|
||||
let fg_bright_black = constr "Fg_bright_black" unit (fun () -> `Fg_bright_black) in
|
||||
let fg_bright_red = constr "Fg_bright_red" unit (fun () -> `Fg_bright_red) in
|
||||
let fg_bright_green = constr "Fg_bright_green" unit (fun () -> `Fg_bright_green) in
|
||||
let fg_bright_yellow =
|
||||
constr "Fg_bright_yellow" unit (fun () -> `Fg_bright_yellow)
|
||||
in
|
||||
let fg_bright_blue = constr "Fg_bright_blue" unit (fun () -> `Fg_bright_blue) in
|
||||
let fg_bright_magenta =
|
||||
constr "Fg_bright_magenta" unit (fun () -> `Fg_bright_magenta)
|
||||
in
|
||||
let fg_bright_cyan = constr "Fg_bright_cyan" unit (fun () -> `Fg_bright_cyan) in
|
||||
let fg_bright_white = constr "Fg_bright_white" unit (fun () -> `Fg_bright_white) in
|
||||
let fg_8_bit_color =
|
||||
constr "Fg_8_bit_color" RGB8.sexp (fun c -> `Fg_8_bit_color c)
|
||||
in
|
||||
let fg_24_bit_color =
|
||||
constr "Fg_24_bit_color" RGB24.sexp (fun c -> `Fg_24_bit_color c)
|
||||
in
|
||||
let bg_default = constr "Bg_default" unit (fun () -> `Bg_default) in
|
||||
let bg_black = constr "Bg_black" unit (fun () -> `Bg_black) in
|
||||
let bg_red = constr "Bg_red" unit (fun () -> `Bg_red) in
|
||||
let bg_green = constr "Bg_green" unit (fun () -> `Bg_green) in
|
||||
let bg_yellow = constr "Bg_yellow" unit (fun () -> `Bg_yellow) in
|
||||
let bg_blue = constr "Bg_blue" unit (fun () -> `Bg_blue) in
|
||||
let bg_magenta = constr "Bg_magenta" unit (fun () -> `Bg_magenta) in
|
||||
let bg_cyan = constr "Bg_cyan" unit (fun () -> `Bg_cyan) in
|
||||
let bg_white = constr "Bg_white" unit (fun () -> `Bg_white) in
|
||||
let bg_bright_black = constr "Bg_bright_black" unit (fun () -> `Bg_bright_black) in
|
||||
let bg_bright_red = constr "Bg_bright_red" unit (fun () -> `Bg_bright_red) in
|
||||
let bg_bright_green = constr "Bg_bright_green" unit (fun () -> `Bg_bright_green) in
|
||||
let bg_bright_yellow =
|
||||
constr "Bg_bright_yellow" unit (fun () -> `Bg_bright_yellow)
|
||||
in
|
||||
let bg_bright_blue = constr "Bg_bright_blue" unit (fun () -> `Bg_bright_blue) in
|
||||
let bg_bright_magenta =
|
||||
constr "Bg_bright_magenta" unit (fun () -> `Bg_bright_magenta)
|
||||
in
|
||||
let bg_bright_cyan = constr "Bg_bright_cyan" unit (fun () -> `Bg_bright_cyan) in
|
||||
let bg_bright_white = constr "Bg_bright_white" unit (fun () -> `Bg_bright_white) in
|
||||
let bg_8_bit_color =
|
||||
constr "Bg_8_bit_color" RGB8.sexp (fun c -> `Bg_8_bit_color c)
|
||||
in
|
||||
let bg_24_bit_color =
|
||||
constr "Bg_24_bit_color" RGB24.sexp (fun c -> `Bg_24_bit_color c)
|
||||
in
|
||||
let bold = constr "Bold" unit (fun () -> `Bold) in
|
||||
let dim = constr "Dim" unit (fun () -> `Dim) in
|
||||
let italic = constr "Italic" unit (fun () -> `Italic) in
|
||||
let underline = constr "Underline" unit (fun () -> `Underline) in
|
||||
sum
|
||||
[ econstr fg_default
|
||||
; econstr fg_black
|
||||
; econstr fg_red
|
||||
; econstr fg_green
|
||||
; econstr fg_yellow
|
||||
; econstr fg_blue
|
||||
; econstr fg_magenta
|
||||
; econstr fg_cyan
|
||||
; econstr fg_white
|
||||
; econstr fg_bright_black
|
||||
; econstr fg_bright_red
|
||||
; econstr fg_bright_green
|
||||
; econstr fg_bright_yellow
|
||||
; econstr fg_bright_blue
|
||||
; econstr fg_bright_magenta
|
||||
; econstr fg_bright_cyan
|
||||
; econstr fg_bright_white
|
||||
; econstr fg_8_bit_color
|
||||
; econstr fg_24_bit_color
|
||||
; econstr bg_default
|
||||
; econstr bg_black
|
||||
; econstr bg_red
|
||||
; econstr bg_green
|
||||
; econstr bg_yellow
|
||||
; econstr bg_blue
|
||||
; econstr bg_magenta
|
||||
; econstr bg_cyan
|
||||
; econstr bg_white
|
||||
; econstr bg_bright_black
|
||||
; econstr bg_bright_red
|
||||
; econstr bg_bright_green
|
||||
; econstr bg_bright_yellow
|
||||
; econstr bg_bright_blue
|
||||
; econstr bg_bright_magenta
|
||||
; econstr bg_bright_cyan
|
||||
; econstr bg_bright_white
|
||||
; econstr bg_8_bit_color
|
||||
; econstr bg_24_bit_color
|
||||
; econstr bold
|
||||
; econstr dim
|
||||
; econstr italic
|
||||
; econstr underline
|
||||
]
|
||||
(function
|
||||
| `Fg_default -> case () fg_default
|
||||
| `Fg_black -> case () fg_black
|
||||
| `Fg_red -> case () fg_red
|
||||
| `Fg_green -> case () fg_green
|
||||
| `Fg_yellow -> case () fg_yellow
|
||||
| `Fg_blue -> case () fg_blue
|
||||
| `Fg_magenta -> case () fg_magenta
|
||||
| `Fg_cyan -> case () fg_cyan
|
||||
| `Fg_white -> case () fg_white
|
||||
| `Fg_bright_black -> case () fg_bright_black
|
||||
| `Fg_bright_red -> case () fg_bright_red
|
||||
| `Fg_bright_green -> case () fg_bright_green
|
||||
| `Fg_bright_yellow -> case () fg_bright_yellow
|
||||
| `Fg_bright_blue -> case () fg_bright_blue
|
||||
| `Fg_bright_magenta -> case () fg_bright_magenta
|
||||
| `Fg_bright_cyan -> case () fg_bright_cyan
|
||||
| `Fg_bright_white -> case () fg_bright_white
|
||||
| `Fg_8_bit_color c -> case c fg_8_bit_color
|
||||
| `Fg_24_bit_color c -> case c fg_24_bit_color
|
||||
| `Bg_default -> case () bg_default
|
||||
| `Bg_black -> case () bg_black
|
||||
| `Bg_red -> case () bg_red
|
||||
| `Bg_green -> case () bg_green
|
||||
| `Bg_yellow -> case () bg_yellow
|
||||
| `Bg_blue -> case () bg_blue
|
||||
| `Bg_magenta -> case () bg_magenta
|
||||
| `Bg_cyan -> case () bg_cyan
|
||||
| `Bg_white -> case () bg_white
|
||||
| `Bg_bright_black -> case () bg_bright_black
|
||||
| `Bg_bright_red -> case () bg_bright_red
|
||||
| `Bg_bright_green -> case () bg_bright_green
|
||||
| `Bg_bright_yellow -> case () bg_bright_yellow
|
||||
| `Bg_bright_blue -> case () bg_bright_blue
|
||||
| `Bg_bright_magenta -> case () bg_bright_magenta
|
||||
| `Bg_bright_cyan -> case () bg_bright_cyan
|
||||
| `Bg_bright_white -> case () bg_bright_white
|
||||
| `Bg_8_bit_color c -> case c bg_8_bit_color
|
||||
| `Bg_24_bit_color c -> case c bg_24_bit_color
|
||||
| `Bold -> case () bold
|
||||
| `Dim -> case () dim
|
||||
| `Italic -> case () italic
|
||||
| `Underline -> case () underline)
|
||||
;;
|
||||
end
|
||||
end
|
||||
|
||||
module Pp = struct
|
||||
include Pp
|
||||
|
||||
let sexp (conv_tag : 'a Conv.value) : 'a Pp.t Conv.value =
|
||||
let open Conv in
|
||||
let open Pp.Ast in
|
||||
let nop = constr "Nop" unit (fun () -> Nop) in
|
||||
let verbatim = constr "Verbatim" string (fun s -> Verbatim s) in
|
||||
let char = constr "Char" char (fun c -> Char c) in
|
||||
let newline = constr "Newline" unit (fun () -> Newline) in
|
||||
let t =
|
||||
fixpoint (fun t ->
|
||||
let text = constr "Text" string (fun s -> Text s) in
|
||||
let seq = constr "Seq" (pair t t) (fun (x, y) -> Seq (x, y)) in
|
||||
let concat = constr "Concat" (pair t (list t)) (fun (x, y) -> Concat (x, y)) in
|
||||
let box = constr "Box" (pair int t) (fun (x, y) -> Box (x, y)) in
|
||||
let vbox = constr "Vbox" (pair int t) (fun (x, y) -> Vbox (x, y)) in
|
||||
let hbox = constr "Hbox" t (fun t -> Hbox t) in
|
||||
let hvbox = constr "Hvbox" (pair int t) (fun (x, y) -> Hvbox (x, y)) in
|
||||
let hovbox = constr "Hovbox" (pair int t) (fun (x, y) -> Hovbox (x, y)) in
|
||||
let break =
|
||||
constr
|
||||
"Break"
|
||||
(pair (triple string int string) (triple string int string))
|
||||
(fun (x, y) -> Break (x, y))
|
||||
in
|
||||
let tag = constr "Tag" (pair conv_tag t) (fun (s, t) -> Tag (s, t)) in
|
||||
sum
|
||||
[ econstr nop
|
||||
; econstr verbatim
|
||||
; econstr char
|
||||
; econstr newline
|
||||
; econstr text
|
||||
; econstr seq
|
||||
; econstr concat
|
||||
; econstr box
|
||||
; econstr vbox
|
||||
; econstr hbox
|
||||
; econstr hvbox
|
||||
; econstr hovbox
|
||||
; econstr break
|
||||
; econstr tag
|
||||
]
|
||||
(function
|
||||
| Nop -> case () nop
|
||||
| Seq (x, y) -> case (x, y) seq
|
||||
| Concat (x, y) -> case (x, y) concat
|
||||
| Box (i, t) -> case (i, t) box
|
||||
| Vbox (i, t) -> case (i, t) vbox
|
||||
| Hbox t -> case t hbox
|
||||
| Hvbox (i, t) -> case (i, t) hvbox
|
||||
| Hovbox (i, t) -> case (i, t) hovbox
|
||||
| Verbatim s -> case s verbatim
|
||||
| Char c -> case c char
|
||||
| Break (x, y) -> case (x, y) break
|
||||
| Newline -> case () newline
|
||||
| Text s -> case s text
|
||||
| Tag (s, t) -> case (s, t) tag))
|
||||
in
|
||||
iso t Pp.of_ast Pp.to_ast
|
||||
;;
|
||||
end
|
||||
|
||||
module User_message = struct
|
||||
include Stdune.User_message
|
||||
|
||||
module Style = struct
|
||||
type t = Stdune.User_message.Style.t =
|
||||
| Loc
|
||||
| Error
|
||||
| Warning
|
||||
| Kwd
|
||||
| Id
|
||||
| Prompt
|
||||
| Hint
|
||||
| Details
|
||||
| Ok
|
||||
| Debug
|
||||
| Success
|
||||
| Ansi_styles of Ansi_color.Style.t list
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let loc = constr "Loc" unit (fun () -> Loc) in
|
||||
let error = constr "Error" unit (fun () -> Error) in
|
||||
let warning = constr "Warning" unit (fun () -> Warning) in
|
||||
let kwd = constr "Kwd" unit (fun () -> Kwd) in
|
||||
let id = constr "Id" unit (fun () -> Id) in
|
||||
let prompt = constr "Prompt" unit (fun () -> Prompt) in
|
||||
let hint = constr "Hint" unit (fun () -> Hint) in
|
||||
let details = constr "Details" unit (fun () -> Details) in
|
||||
let ok = constr "Ok" unit (fun () -> Ok) in
|
||||
let debug = constr "Debug" unit (fun () -> Debug) in
|
||||
let success = constr "Success" unit (fun () -> Success) in
|
||||
let ansi_styles =
|
||||
constr "Ansi_styles" (list Ansi_color.Style.sexp) (fun l -> Ansi_styles l)
|
||||
in
|
||||
sum
|
||||
[ econstr loc
|
||||
; econstr error
|
||||
; econstr warning
|
||||
; econstr kwd
|
||||
; econstr id
|
||||
; econstr prompt
|
||||
; econstr hint
|
||||
; econstr details
|
||||
; econstr ok
|
||||
; econstr debug
|
||||
; econstr success
|
||||
; econstr ansi_styles
|
||||
]
|
||||
(function
|
||||
| Loc -> case () loc
|
||||
| Error -> case () error
|
||||
| Warning -> case () warning
|
||||
| Kwd -> case () kwd
|
||||
| Id -> case () id
|
||||
| Prompt -> case () prompt
|
||||
| Hint -> case () hint
|
||||
| Details -> case () details
|
||||
| Ok -> case () ok
|
||||
| Debug -> case () debug
|
||||
| Success -> case () success
|
||||
| Ansi_styles l -> case l ansi_styles)
|
||||
;;
|
||||
end
|
||||
|
||||
let sexp_without_annots =
|
||||
let open Conv in
|
||||
let sexp_pp = Pp.sexp Style.sexp in
|
||||
let from { loc; paragraphs; hints; annots = _; context; dir } =
|
||||
let loc = Option.map loc ~f:Import.Loc.to_lexbuf_loc in
|
||||
loc, paragraphs, hints, context, dir
|
||||
in
|
||||
let to_ (loc, paragraphs, hints, context, dir) =
|
||||
let loc = Option.map loc ~f:Import.Loc.of_lexbuf_loc in
|
||||
{ loc; paragraphs; hints; context; dir; annots = Annots.empty }
|
||||
in
|
||||
let loc = field "loc" (optional Loc.sexp) in
|
||||
let paragraphs = field "paragraphs" (required (list sexp_pp)) in
|
||||
let hints = field "hints" (required (list sexp_pp)) in
|
||||
let context = field "context" (optional string) in
|
||||
let dir = field "dir" (optional string) in
|
||||
iso (record (five loc paragraphs hints context dir)) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
module Target = struct
|
||||
type t =
|
||||
| Path of string
|
||||
| Alias of string
|
||||
| Library of string
|
||||
| Executables of string list
|
||||
| Preprocess of string list
|
||||
| Loc of Loc.t
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let path = constr "Path" string (fun p -> Path p) in
|
||||
let alias = constr "Alias" string (fun a -> Alias a) in
|
||||
let lib = constr "Library" string (fun l -> Library l) in
|
||||
let executables = constr "Executables" (list string) (fun es -> Executables es) in
|
||||
let preprocess = constr "Preprocess" (list string) (fun ps -> Preprocess ps) in
|
||||
let loc = constr "Loc" Loc.sexp (fun l -> Loc l) in
|
||||
sum
|
||||
[ econstr path
|
||||
; econstr alias
|
||||
; econstr lib
|
||||
; econstr executables
|
||||
; econstr preprocess
|
||||
; econstr loc
|
||||
]
|
||||
(function
|
||||
| Path p -> case p path
|
||||
| Alias a -> case a alias
|
||||
| Library l -> case l lib
|
||||
| Executables es -> case es executables
|
||||
| Preprocess ps -> case ps preprocess
|
||||
| Loc l -> case l loc)
|
||||
;;
|
||||
end
|
||||
|
||||
module Path = struct
|
||||
type t = string
|
||||
|
||||
let sexp = Conv.string
|
||||
let dune_root = "."
|
||||
let to_string_absolute x = x
|
||||
|
||||
let absolute abs =
|
||||
if Filename.is_relative abs
|
||||
then
|
||||
Code_error.raise
|
||||
"Path.absolute: accepts only absolute paths"
|
||||
[ "abs", Dyn.string abs ];
|
||||
abs
|
||||
;;
|
||||
|
||||
let relative = Filename.concat
|
||||
end
|
||||
|
||||
(* This has a subtle difference with [sexp_pp] in how we serialise tags. *)
|
||||
let sexp_pp_unit : unit Pp.t Conv.value =
|
||||
let open Conv in
|
||||
let open Pp.Ast in
|
||||
let nop = constr "Nop" unit (fun () -> Nop) in
|
||||
let verbatim = constr "Verbatim" string (fun s -> Verbatim s) in
|
||||
let char = constr "Char" char (fun c -> Char c) in
|
||||
let newline = constr "Newline" unit (fun () -> Newline) in
|
||||
let t =
|
||||
fixpoint (fun t ->
|
||||
let text = constr "Text" string (fun s -> Text s) in
|
||||
let seq = constr "Seq" (pair t t) (fun (x, y) -> Seq (x, y)) in
|
||||
let concat = constr "Concat" (pair t (list t)) (fun (x, y) -> Concat (x, y)) in
|
||||
let box = constr "Box" (pair int t) (fun (x, y) -> Box (x, y)) in
|
||||
let vbox = constr "Vbox" (pair int t) (fun (x, y) -> Vbox (x, y)) in
|
||||
let hbox = constr "Hbox" t (fun t -> Hbox t) in
|
||||
let hvbox = constr "Hvbox" (pair int t) (fun (x, y) -> Hvbox (x, y)) in
|
||||
let hovbox = constr "Hovbox" (pair int t) (fun (x, y) -> Hovbox (x, y)) in
|
||||
let break =
|
||||
constr
|
||||
"Break"
|
||||
(pair (triple string int string) (triple string int string))
|
||||
(fun (x, y) -> Break (x, y))
|
||||
in
|
||||
let tag = constr "Tag" t (fun t -> Tag ((), t)) in
|
||||
sum
|
||||
[ econstr nop
|
||||
; econstr verbatim
|
||||
; econstr char
|
||||
; econstr newline
|
||||
; econstr text
|
||||
; econstr seq
|
||||
; econstr concat
|
||||
; econstr box
|
||||
; econstr vbox
|
||||
; econstr hbox
|
||||
; econstr hvbox
|
||||
; econstr hovbox
|
||||
; econstr break
|
||||
; econstr tag
|
||||
]
|
||||
(function
|
||||
| Nop -> case () nop
|
||||
| Seq (x, y) -> case (x, y) seq
|
||||
| Concat (x, y) -> case (x, y) concat
|
||||
| Box (i, t) -> case (i, t) box
|
||||
| Vbox (i, t) -> case (i, t) vbox
|
||||
| Hbox t -> case t hbox
|
||||
| Hvbox (i, t) -> case (i, t) hvbox
|
||||
| Hovbox (i, t) -> case (i, t) hovbox
|
||||
| Verbatim s -> case s verbatim
|
||||
| Char c -> case c char
|
||||
| Break (x, y) -> case (x, y) break
|
||||
| Newline -> case () newline
|
||||
| Text s -> case s text
|
||||
| Tag ((), t) -> case t tag))
|
||||
in
|
||||
iso t Pp.of_ast Pp.to_ast
|
||||
;;
|
||||
|
||||
module Diagnostic = struct
|
||||
type severity =
|
||||
| Error
|
||||
| Warning
|
||||
|
||||
module Promotion = struct
|
||||
type t =
|
||||
{ in_build : string
|
||||
; in_source : string
|
||||
}
|
||||
|
||||
let in_build t = t.in_build
|
||||
let in_source t = t.in_source
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { in_build; in_source } = in_build, in_source in
|
||||
let to_ (in_build, in_source) = { in_build; in_source } in
|
||||
let in_build = field "in_build" (required string) in
|
||||
let in_source = field "in_source" (required string) in
|
||||
iso (record (both in_build in_source)) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
module Id = struct
|
||||
type t = int
|
||||
|
||||
let compare (a : t) (b : t) = Int.compare a b
|
||||
let hash (t : t) = Hashtbl.hash t
|
||||
let create t : t = t
|
||||
let sexp = Conv.int
|
||||
end
|
||||
|
||||
module Related = struct
|
||||
type t =
|
||||
{ message : User_message.Style.t Pp.t
|
||||
; loc : Loc.t
|
||||
}
|
||||
|
||||
let message t = t.message |> Pp.map_tags ~f:(fun _ -> ())
|
||||
let message_with_style t = t.message
|
||||
let loc t = t.loc
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let loc = field "loc" (required Loc.sexp) in
|
||||
let message = field "message" (required (Pp.sexp User_message.Style.sexp)) in
|
||||
let to_ (loc, message) = { loc; message } in
|
||||
let from { loc; message } = loc, message in
|
||||
iso (record (both loc message)) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
type t =
|
||||
{ targets : Target.t list
|
||||
; id : Id.t
|
||||
; message : User_message.Style.t Pp.t
|
||||
; loc : Loc.t option
|
||||
; severity : severity option
|
||||
; promotion : Promotion.t list
|
||||
; directory : string option
|
||||
; related : Related.t list
|
||||
}
|
||||
|
||||
let loc t = t.loc
|
||||
let message t = t.message |> Pp.map_tags ~f:(fun _ -> ())
|
||||
let message_with_style t = t.message
|
||||
let severity t = t.severity
|
||||
let promotion t = t.promotion
|
||||
let targets t = t.targets
|
||||
let directory t = t.directory
|
||||
let related t = t.related
|
||||
let id t = t.id
|
||||
|
||||
let sexp_severity =
|
||||
let open Conv in
|
||||
enum [ "error", Error; "warning", Warning ]
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { targets; message; loc; severity; promotion; directory; id; related } =
|
||||
targets, message, loc, severity, promotion, directory, id, related
|
||||
in
|
||||
let to_ (targets, message, loc, severity, promotion, directory, id, related) =
|
||||
{ targets; message; loc; severity; promotion; directory; id; related }
|
||||
in
|
||||
let loc = field "loc" (optional Loc.sexp) in
|
||||
let message = field "message" (required (Pp.sexp User_message.Style.sexp)) in
|
||||
let targets = field "targets" (required (list Target.sexp)) in
|
||||
let severity = field "severity" (optional sexp_severity) in
|
||||
let directory = field "directory" (optional string) in
|
||||
let promotion = field "promotion" (required (list Promotion.sexp)) in
|
||||
let id = field "id" (required Id.sexp) in
|
||||
let related = field "related" (required (list Related.sexp)) in
|
||||
iso
|
||||
(record (eight targets message loc severity promotion directory id related))
|
||||
to_
|
||||
from
|
||||
;;
|
||||
|
||||
let to_dyn t = Sexp.to_dyn (Conv.to_sexp sexp t)
|
||||
|
||||
let to_user_message t =
|
||||
let loc = Option.map t.loc ~f:Stdune.Loc.of_lexbuf_loc in
|
||||
Stdune.User_message.make ?loc [ t.message ]
|
||||
;;
|
||||
|
||||
module Event = struct
|
||||
type nonrec t =
|
||||
| Add of t
|
||||
| Remove of t
|
||||
|
||||
let sexp =
|
||||
let diagnostic = sexp in
|
||||
let open Conv in
|
||||
let add = constr "Add" diagnostic (fun a -> Add a) in
|
||||
let remove = constr "Remove" diagnostic (fun a -> Remove a) in
|
||||
sum
|
||||
[ econstr add; econstr remove ]
|
||||
(function
|
||||
| Add t -> case t add
|
||||
| Remove t -> case t remove)
|
||||
;;
|
||||
|
||||
let to_dyn t = Sexp.to_dyn (Conv.to_sexp sexp t)
|
||||
end
|
||||
end
|
||||
|
||||
module Progress = struct
|
||||
type t =
|
||||
| Waiting
|
||||
| In_progress of
|
||||
{ complete : int
|
||||
; remaining : int
|
||||
; failed : int
|
||||
}
|
||||
| Failed
|
||||
| Interrupted
|
||||
| Success
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let waiting = constr "waiting" unit (fun () -> Waiting) in
|
||||
let failed = constr "failed" unit (fun () -> Failed) in
|
||||
let in_progress =
|
||||
let complete = field "complete" (required int) in
|
||||
let remaining = field "remaining" (required int) in
|
||||
let failed = field "failed" (required int) in
|
||||
constr
|
||||
"in_progress"
|
||||
(record (three complete remaining failed))
|
||||
(fun (complete, remaining, failed) -> In_progress { complete; remaining; failed })
|
||||
in
|
||||
let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
|
||||
let success = constr "success" unit (fun () -> Success) in
|
||||
let constrs =
|
||||
List.map ~f:econstr [ waiting; failed; interrupted; success ]
|
||||
@ [ econstr in_progress ]
|
||||
in
|
||||
let serialize = function
|
||||
| Waiting -> case () waiting
|
||||
| In_progress { complete; remaining; failed } ->
|
||||
case (complete, remaining, failed) in_progress
|
||||
| Failed -> case () failed
|
||||
| Interrupted -> case () interrupted
|
||||
| Success -> case () success
|
||||
in
|
||||
sum constrs serialize
|
||||
;;
|
||||
end
|
||||
|
||||
module Message = struct
|
||||
type t =
|
||||
{ payload : Sexp.t option
|
||||
; message : string
|
||||
}
|
||||
|
||||
let payload t = t.payload
|
||||
let message t = t.message
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { payload; message } = payload, message in
|
||||
let to_ (payload, message) = { payload; message } in
|
||||
let payload = field "payload" (optional sexp) in
|
||||
let message = field "message" (required string) in
|
||||
iso (record (both payload message)) to_ from
|
||||
;;
|
||||
|
||||
let to_sexp_unversioned = Conv.to_sexp sexp
|
||||
end
|
||||
|
||||
module Job = struct
|
||||
module Id = Diagnostic.Id
|
||||
|
||||
type t =
|
||||
{ id : Id.t
|
||||
; pid : int
|
||||
; description : unit Pp.t
|
||||
; started_at : float
|
||||
}
|
||||
|
||||
let id t = t.id
|
||||
let pid t = t.pid
|
||||
let description t = t.description
|
||||
let started_at t = t.started_at
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { id; pid; description; started_at } = id, pid, description, started_at in
|
||||
let to_ (id, pid, description, started_at) = { id; pid; description; started_at } in
|
||||
let id = field "id" (required Id.sexp) in
|
||||
let started_at = field "started_at" (required float) in
|
||||
let pid = field "pid" (required int) in
|
||||
let description = field "description" (required sexp_pp_unit) in
|
||||
iso (record (four id pid description started_at)) to_ from
|
||||
;;
|
||||
|
||||
module Event = struct
|
||||
type nonrec t =
|
||||
| Start of t
|
||||
| Stop of Id.t
|
||||
|
||||
let sexp =
|
||||
let job = sexp in
|
||||
let open Conv in
|
||||
let start = constr "Start" job (fun a -> Start a) in
|
||||
let stop = constr "Stop" Id.sexp (fun a -> Stop a) in
|
||||
sum
|
||||
[ econstr start; econstr stop ]
|
||||
(function
|
||||
| Start t -> case t start
|
||||
| Stop t -> case t stop)
|
||||
;;
|
||||
end
|
||||
end
|
||||
|
||||
module Compound_user_error = struct
|
||||
type t =
|
||||
{ main : User_message.t
|
||||
; related : User_message.t list
|
||||
}
|
||||
|
||||
let create ~main ~related =
|
||||
let () =
|
||||
List.iter related ~f:(fun (related : User_message.t) ->
|
||||
match related.loc with
|
||||
| Some _ -> ()
|
||||
| None ->
|
||||
Code_error.raise
|
||||
"related messages must have locations"
|
||||
[ "related", String (Stdune.User_message.to_string related) ])
|
||||
in
|
||||
{ main; related }
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let from { main; related } = main, related in
|
||||
let to_ (main, related) = create ~main ~related in
|
||||
let main = field "main" (required User_message.sexp_without_annots) in
|
||||
let related = field "related" (required (list User_message.sexp_without_annots)) in
|
||||
iso (record (both main related)) to_ from
|
||||
;;
|
||||
|
||||
let to_dyn { main; related } =
|
||||
let open Dyn in
|
||||
record
|
||||
[ "main", string (Stdune.User_message.to_string main)
|
||||
; "related", (list string) (List.map related ~f:Stdune.User_message.to_string)
|
||||
]
|
||||
;;
|
||||
|
||||
let annot =
|
||||
Stdune.User_message.Annots.Key.create ~name:"compound-user-error" (Dyn.list to_dyn)
|
||||
;;
|
||||
|
||||
let make ~main ~related = create ~main ~related
|
||||
|
||||
let make_loc ~dir { Ocamlc_loc.path; chars; lines } : Stdune.Loc.t =
|
||||
let pos_fname =
|
||||
let dir = Stdune.Path.drop_optional_build_context_maybe_sandboxed dir in
|
||||
Stdune.Path.to_absolute_filename (Stdune.Path.relative dir path)
|
||||
in
|
||||
let pos_lnum_start, pos_lnum_stop =
|
||||
match lines with
|
||||
| Single i -> i, i
|
||||
| Range (i, j) -> i, j
|
||||
in
|
||||
let pos_cnum_start, pos_cnum_stop =
|
||||
match chars with
|
||||
| None -> 0, 0
|
||||
| Some (x, y) -> x, y
|
||||
in
|
||||
let pos = { Lexing.pos_fname; pos_lnum = 0; pos_bol = 0; pos_cnum = 0 } in
|
||||
let start = { pos with pos_lnum = pos_lnum_start; pos_cnum = pos_cnum_start } in
|
||||
let stop = { pos with pos_lnum = pos_lnum_stop; pos_cnum = pos_cnum_stop } in
|
||||
Stdune.Loc.create ~start ~stop
|
||||
;;
|
||||
|
||||
let parse_output ~dir s =
|
||||
Ocamlc_loc.parse s
|
||||
|> List.map ~f:(fun (report : Ocamlc_loc.report) ->
|
||||
let make_message (loc, message) =
|
||||
let loc = make_loc ~dir loc in
|
||||
let message = Pp.verbatim message in
|
||||
Stdune.User_message.make ~loc [ message ]
|
||||
in
|
||||
let main = make_message (report.loc, report.message) in
|
||||
let related = List.map report.related ~f:make_message in
|
||||
make ~main ~related)
|
||||
;;
|
||||
end
|
||||
|
||||
module Build_outcome_with_diagnostics = struct
|
||||
type t =
|
||||
| Success
|
||||
| Failure of Compound_user_error.t list
|
||||
|
||||
let sexp_v1 =
|
||||
let open Conv in
|
||||
let success = constr "Success" unit (fun () -> Success) in
|
||||
let failure = constr "Failure" unit (fun () -> Failure []) in
|
||||
let variants = [ econstr success; econstr failure ] in
|
||||
sum variants (function
|
||||
| Success -> case () success
|
||||
| Failure _ -> case () failure)
|
||||
;;
|
||||
|
||||
let sexp_v2 =
|
||||
let open Conv in
|
||||
let success = constr "Success" unit (fun () -> Success) in
|
||||
let failure =
|
||||
constr "Failure" (list Compound_user_error.sexp) (fun errors -> Failure errors)
|
||||
in
|
||||
let variants = [ econstr success; econstr failure ] in
|
||||
sum variants (function
|
||||
| Success -> case () success
|
||||
| Failure errors -> case errors failure)
|
||||
;;
|
||||
|
||||
let sexp = sexp_v2
|
||||
end
|
||||
|
||||
module Files_to_promote = struct
|
||||
type t =
|
||||
| All
|
||||
| These of Stdune.Path.Source.t list * (Stdune.Path.Source.t -> unit)
|
||||
|
||||
let on_missing fn =
|
||||
Stdune.User_warning.emit
|
||||
[ Pp.paragraphf
|
||||
"Nothing to promote for %s."
|
||||
(Stdune.Path.Source.to_string_maybe_quoted fn)
|
||||
]
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let to_ = function
|
||||
| [] -> All
|
||||
| paths -> These (List.map ~f:Stdune.Path.Source.of_string paths, on_missing)
|
||||
in
|
||||
let from = function
|
||||
| All -> []
|
||||
| These (paths, _) -> List.map ~f:Stdune.Path.Source.to_string paths
|
||||
in
|
||||
iso (list Path.sexp) to_ from
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,257 @@
|
|||
(** Types exposed to end-user consumers of [dune_rpc.mli]. *)
|
||||
|
||||
module Loc : sig
|
||||
type t = Stdune.Lexbuf.Loc.t =
|
||||
{ start : Lexing.position
|
||||
; stop : Lexing.position
|
||||
}
|
||||
|
||||
val start : t -> Lexing.position
|
||||
val stop : t -> Lexing.position
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
(** This is kept around for compatibility reasons. Before we serialised [Pp.t] tags as
|
||||
[(Tag pp)] but now we serialise them as [Tag (pair tag pp)]. *)
|
||||
val sexp_pp_unit : unit Pp.t Conv.value
|
||||
|
||||
module Target : sig
|
||||
type t =
|
||||
| Path of string
|
||||
| Alias of string
|
||||
| Library of string
|
||||
| Executables of string list
|
||||
| Preprocess of string list
|
||||
| Loc of Loc.t
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Path : sig
|
||||
type t = string
|
||||
|
||||
val dune_root : t
|
||||
val absolute : string -> t
|
||||
val relative : t -> string -> t
|
||||
val to_string_absolute : t -> string
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Ansi_color : sig
|
||||
module RGB8 : sig
|
||||
type t = Stdune.Ansi_color.RGB8.t
|
||||
|
||||
val to_int : t -> int
|
||||
val of_int : int -> t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module RGB24 : sig
|
||||
type t = Stdune.Ansi_color.RGB24.t
|
||||
|
||||
val to_int : t -> int
|
||||
val of_int : int -> t
|
||||
val red : t -> int
|
||||
val green : t -> int
|
||||
val blue : t -> int
|
||||
val make : red:int -> green:int -> blue:int -> t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Style : sig
|
||||
type t = Stdune.Ansi_color.Style.t
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module User_message : sig
|
||||
module Style : sig
|
||||
type t = Stdune.User_message.Style.t =
|
||||
| Loc
|
||||
| Error
|
||||
| Warning
|
||||
| Kwd
|
||||
| Id
|
||||
| Prompt
|
||||
| Hint
|
||||
| Details
|
||||
| Ok
|
||||
| Debug
|
||||
| Success
|
||||
| Ansi_styles of Ansi_color.Style.t list
|
||||
end
|
||||
|
||||
type t = Stdune.User_message.t
|
||||
|
||||
(** (De)serializer for [User_message.t] which ignores the [annots] field. The
|
||||
[annots] field is non-trivial to serialize and is not necessary for
|
||||
formatting messages, so it's not handled here. *)
|
||||
val sexp_without_annots : t Conv.value
|
||||
end
|
||||
|
||||
module Diagnostic : sig
|
||||
type severity =
|
||||
| Error
|
||||
| Warning
|
||||
|
||||
module Promotion : sig
|
||||
type t =
|
||||
{ in_build : string
|
||||
; in_source : string
|
||||
}
|
||||
|
||||
val in_build : t -> string
|
||||
val in_source : t -> string
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> Ordering.t
|
||||
val hash : t -> int
|
||||
val create : int -> t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Related : sig
|
||||
type t =
|
||||
{ message : User_message.Style.t Pp.t
|
||||
; loc : Loc.t
|
||||
}
|
||||
|
||||
val message : t -> unit Pp.t
|
||||
val message_with_style : t -> User_message.Style.t Pp.t
|
||||
val loc : t -> Loc.t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
type t =
|
||||
{ targets : Target.t list
|
||||
; id : Id.t
|
||||
; message : User_message.Style.t Pp.t
|
||||
; loc : Loc.t option
|
||||
; severity : severity option
|
||||
; promotion : Promotion.t list
|
||||
; directory : string option
|
||||
; related : Related.t list
|
||||
}
|
||||
|
||||
val related : t -> Related.t list
|
||||
val id : t -> Id.t
|
||||
val loc : t -> Loc.t option
|
||||
val message : t -> unit Pp.t
|
||||
val message_with_style : t -> User_message.Style.t Pp.t
|
||||
val severity : t -> severity option
|
||||
val promotion : t -> Promotion.t list
|
||||
val targets : t -> Target.t list
|
||||
val directory : t -> string option
|
||||
val to_dyn : t -> Dyn.t
|
||||
val to_user_message : t -> Stdune.User_message.t
|
||||
|
||||
module Event : sig
|
||||
type nonrec t =
|
||||
| Add of t
|
||||
| Remove of t
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Progress : sig
|
||||
type t =
|
||||
| Waiting
|
||||
| In_progress of
|
||||
{ complete : int
|
||||
; remaining : int
|
||||
; failed : int
|
||||
}
|
||||
| Failed
|
||||
| Interrupted
|
||||
| Success
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Message : sig
|
||||
type t =
|
||||
{ payload : Csexp.t option
|
||||
; message : string
|
||||
}
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
val sexp : t Conv.value
|
||||
val to_sexp_unversioned : t -> Csexp.t
|
||||
end
|
||||
|
||||
module Job : sig
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> Ordering.t
|
||||
val hash : t -> int
|
||||
val create : int -> t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
type t =
|
||||
{ id : Id.t
|
||||
; pid : int
|
||||
; description : unit Pp.t
|
||||
; started_at : float
|
||||
}
|
||||
|
||||
val id : t -> Id.t
|
||||
val pid : t -> int
|
||||
val description : t -> unit Pp.t
|
||||
val started_at : t -> float
|
||||
|
||||
module Event : sig
|
||||
type nonrec t =
|
||||
| Start of t
|
||||
| Stop of Id.t
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
(** A compound user error defineds an alternative format for error messages that
|
||||
retains more structure. This can be used to display the errors in richer
|
||||
form by RPC clients. *)
|
||||
module Compound_user_error : sig
|
||||
type t = private
|
||||
{ main : User_message.t
|
||||
; related : User_message.t list
|
||||
}
|
||||
|
||||
val sexp : t Conv.value
|
||||
val to_dyn : t -> Dyn.t
|
||||
val annot : t list Stdune.User_message.Annots.Key.t
|
||||
val make : main:User_message.t -> related:User_message.t list -> t
|
||||
val parse_output : dir:Stdune.Path.t -> string -> t list
|
||||
end
|
||||
|
||||
module Build_outcome_with_diagnostics : sig
|
||||
type t =
|
||||
| Success
|
||||
| Failure of Compound_user_error.t list
|
||||
|
||||
val sexp_v1 : t Conv.value
|
||||
val sexp_v2 : t Conv.value
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
(** Describe what files should be promoted. The second argument of [These] is a
|
||||
function that is called on files that cannot be promoted. *)
|
||||
module Files_to_promote : sig
|
||||
type t =
|
||||
| All
|
||||
| These of Stdune.Path.Source.t list * (Stdune.Path.Source.t -> unit)
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
module type S = sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val fork_and_join_unit : (unit -> unit t) -> (unit -> 'a t) -> 'a t
|
||||
val parallel_iter : (unit -> 'a option t) -> f:('a -> unit t) -> unit t
|
||||
val finalize : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
|
||||
module Ivar : sig
|
||||
type 'a fiber := 'a t
|
||||
type 'a t
|
||||
|
||||
val create : unit -> 'a t
|
||||
val read : 'a t -> 'a fiber
|
||||
val fill : 'a t -> 'a -> unit fiber
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
include struct
|
||||
open Stdune
|
||||
module Sexp = Sexp
|
||||
module String = String
|
||||
module List = List
|
||||
module Either = Either
|
||||
module Int = Int
|
||||
module Poly = Poly
|
||||
module Code_error = Code_error
|
||||
module Env = Env
|
||||
module Comparable = Comparable
|
||||
module Result = Result
|
||||
module Option = Option
|
||||
module Table = Table
|
||||
module Set = Set
|
||||
module Io = Io
|
||||
module Loc = Loc
|
||||
module Fdecl = Fdecl
|
||||
module Univ_map = Univ_map
|
||||
module Comparable_intf = Comparable_intf
|
||||
|
||||
module Path = struct
|
||||
(* we don't want to depend on build or source directories here *)
|
||||
end
|
||||
end
|
||||
47
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/menu.ml
Normal file
47
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/menu.ml
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
open Import
|
||||
open Types
|
||||
|
||||
(* This list of methods and generations is exactly the list of existing methods
|
||||
as of commit [3cd240e], which the initial versioning implementation was based
|
||||
on. *)
|
||||
let compatibility_menu =
|
||||
Method.Name.Map.of_list_exn
|
||||
[ "ping", 1
|
||||
; "diagnostics", 1
|
||||
; "shutdown", 1
|
||||
; "subscribe", 1
|
||||
; "unsubscribe", 1
|
||||
; "build", 1
|
||||
; "status", 1
|
||||
; "notify/abort", 1
|
||||
; "notify/diagnostic", 1
|
||||
; "notify/log", 1
|
||||
; "notify/progress", 1
|
||||
]
|
||||
;;
|
||||
|
||||
type t = Method.Version.t Method.Name.Map.t
|
||||
|
||||
let default = compatibility_menu
|
||||
let find = Method.Name.Map.find
|
||||
|
||||
let select_common ~local_versions ~remote_versions =
|
||||
let selected_versions =
|
||||
List.filter_map remote_versions ~f:(fun (method_, remote_versions) ->
|
||||
let remote_versions = Method.Version.Set.of_list remote_versions in
|
||||
let open Option.O in
|
||||
let* local_versions = Method.Name.Map.find local_versions method_ in
|
||||
let+ greatest_common_version =
|
||||
Method.Version.Set.max_elt
|
||||
(Method.Version.Set.inter remote_versions local_versions)
|
||||
in
|
||||
method_, greatest_common_version)
|
||||
in
|
||||
match selected_versions with
|
||||
| [] -> None
|
||||
| _ :: _ -> Some (Method.Name.Map.of_list_exn selected_versions)
|
||||
;;
|
||||
|
||||
let of_list = Method.Name.Map.of_list
|
||||
let to_list = Method.Name.Map.to_list
|
||||
let to_dyn = Method.Name.Map.to_dyn Int.to_dyn
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
open Types
|
||||
|
||||
type t
|
||||
|
||||
val default : t
|
||||
val find : t -> Method.Name.t -> Method.Version.t option
|
||||
|
||||
(** For each method known by both local and remote, choose the highest common
|
||||
version number. Returns [None] if the resulting menu would be empty. *)
|
||||
val select_common
|
||||
: local_versions:Method.Version.Set.t Method.Name.Map.t
|
||||
-> remote_versions:(Method.Name.t * Method.Version.t list) list
|
||||
-> t option
|
||||
|
||||
val of_list
|
||||
: (Method.Name.t * Method.Version.t) list
|
||||
-> (t, Method.Name.t * Method.Version.t * Method.Version.t) result
|
||||
|
||||
val to_list : t -> (Method.Name.t * Method.Version.t) list
|
||||
val to_dyn : t -> Dyn.t
|
||||
|
|
@ -0,0 +1,253 @@
|
|||
open Import
|
||||
open Types
|
||||
open Exported_types
|
||||
|
||||
module Public = struct
|
||||
module Ping = struct
|
||||
let v1 = Decl.Request.make_current_gen ~req:Conv.unit ~resp:Conv.unit ~version:1
|
||||
let decl = Decl.Request.make ~method_:"ping" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Diagnostics = struct
|
||||
let v1 =
|
||||
Decl.Request.make_gen
|
||||
~version:1
|
||||
~req:Conv.unit
|
||||
~resp:(Conv.list Diagnostics_v1.sexp)
|
||||
~upgrade_req:Fun.id
|
||||
~downgrade_req:Fun.id
|
||||
~upgrade_resp:(List.map ~f:Diagnostics_v1.to_diagnostic)
|
||||
~downgrade_resp:(List.map ~f:Diagnostics_v1.of_diagnostic)
|
||||
;;
|
||||
|
||||
let v2 =
|
||||
Decl.Request.make_current_gen
|
||||
~version:2
|
||||
~req:Conv.unit
|
||||
~resp:(Conv.list Diagnostic.sexp)
|
||||
;;
|
||||
|
||||
let decl = Decl.Request.make ~method_:"diagnostics" ~generations:[ v1; v2 ]
|
||||
end
|
||||
|
||||
module Shutdown = struct
|
||||
let v1 = Decl.Notification.make_current_gen ~conv:Conv.unit ~version:1
|
||||
let decl = Decl.Notification.make ~method_:"shutdown" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Format_dune_file = struct
|
||||
module V1 = struct
|
||||
let req =
|
||||
let open Conv in
|
||||
let path = field "path" (required string) in
|
||||
let contents = field "contents" (required string) in
|
||||
let to_ (path, contents) = path, `Contents contents in
|
||||
let from (path, `Contents contents) = path, contents in
|
||||
iso (record (both path contents)) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
let v1 = Decl.Request.make_current_gen ~req:V1.req ~resp:Conv.string ~version:1
|
||||
let decl = Decl.Request.make ~method_:"format-dune-file" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Promote = struct
|
||||
let v1 = Decl.Request.make_current_gen ~req:Path.sexp ~resp:Conv.unit ~version:1
|
||||
let decl = Decl.Request.make ~method_:"promote" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Promote_many = struct
|
||||
let v1 =
|
||||
Decl.Request.make_current_gen
|
||||
~req:Files_to_promote.sexp
|
||||
~resp:Build_outcome_with_diagnostics.sexp
|
||||
~version:1
|
||||
;;
|
||||
|
||||
let decl = Decl.Request.make ~method_:"promote_many" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Build_dir = struct
|
||||
let v1 = Decl.Request.make_current_gen ~req:Conv.unit ~resp:Path.sexp ~version:1
|
||||
let decl = Decl.Request.make ~method_:"build_dir" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
let ping = Ping.decl
|
||||
let diagnostics = Diagnostics.decl
|
||||
let shutdown = Shutdown.decl
|
||||
let format_dune_file = Format_dune_file.decl
|
||||
let promote = Promote.decl
|
||||
let promote_many = Promote_many.decl
|
||||
let build_dir = Build_dir.decl
|
||||
end
|
||||
|
||||
module Server_side = struct
|
||||
module Abort = struct
|
||||
let v1 = Decl.Notification.make_current_gen ~conv:Message.sexp ~version:1
|
||||
let decl = Decl.Notification.make ~method_:"notify/abort" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
module Log = struct
|
||||
let v1 = Decl.Notification.make_current_gen ~conv:Message.sexp ~version:1
|
||||
let decl = Decl.Notification.make ~method_:"notify/log" ~generations:[ v1 ]
|
||||
end
|
||||
|
||||
let abort = Abort.decl
|
||||
let log = Log.decl
|
||||
end
|
||||
|
||||
module Poll = struct
|
||||
let cancel_gen = Decl.Notification.make_current_gen ~conv:Id.sexp ~version:1
|
||||
|
||||
module Name = struct
|
||||
include String
|
||||
|
||||
let make s = s
|
||||
end
|
||||
|
||||
type 'a t =
|
||||
{ poll : (Id.t, 'a option) Decl.request
|
||||
; cancel : Id.t Decl.notification
|
||||
; name : Name.t
|
||||
}
|
||||
|
||||
let make name generations =
|
||||
let poll = Decl.Request.make ~method_:("poll/" ^ name) ~generations in
|
||||
let cancel =
|
||||
Decl.Notification.make ~method_:("cancel-poll/" ^ name) ~generations:[ cancel_gen ]
|
||||
in
|
||||
{ poll; cancel; name }
|
||||
;;
|
||||
|
||||
let poll t = t.poll
|
||||
let cancel t = t.cancel
|
||||
let name t = t.name
|
||||
|
||||
module Progress = struct
|
||||
module V1 = struct
|
||||
type t =
|
||||
| Waiting
|
||||
| In_progress of
|
||||
{ complete : int
|
||||
; remaining : int
|
||||
}
|
||||
| Failed
|
||||
| Interrupted
|
||||
| Success
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let waiting = constr "waiting" unit (fun () -> Waiting) in
|
||||
let failed = constr "failed" unit (fun () -> Failed) in
|
||||
let in_progress =
|
||||
let complete = field "complete" (required int) in
|
||||
let remaining = field "remaining" (required int) in
|
||||
constr
|
||||
"in_progress"
|
||||
(record (both complete remaining))
|
||||
(fun (complete, remaining) -> In_progress { complete; remaining })
|
||||
in
|
||||
let interrupted = constr "interrupted" unit (fun () -> Interrupted) in
|
||||
let success = constr "success" unit (fun () -> Success) in
|
||||
let constrs =
|
||||
List.map ~f:econstr [ waiting; failed; interrupted; success ]
|
||||
@ [ econstr in_progress ]
|
||||
in
|
||||
let serialize = function
|
||||
| Waiting -> case () waiting
|
||||
| In_progress { complete; remaining } -> case (complete, remaining) in_progress
|
||||
| Failed -> case () failed
|
||||
| Interrupted -> case () interrupted
|
||||
| Success -> case () success
|
||||
in
|
||||
sum constrs serialize
|
||||
;;
|
||||
|
||||
let to_progress : t -> Progress.t = function
|
||||
| Waiting -> Waiting
|
||||
| In_progress { complete; remaining } ->
|
||||
In_progress { complete; remaining; failed = 0 }
|
||||
| Failed -> Failed
|
||||
| Interrupted -> Interrupted
|
||||
| Success -> Success
|
||||
;;
|
||||
|
||||
let of_progress : Progress.t -> t = function
|
||||
| Waiting -> Waiting
|
||||
| In_progress { complete; remaining; failed = _ } ->
|
||||
In_progress { complete; remaining }
|
||||
| Failed -> Failed
|
||||
| Interrupted -> Interrupted
|
||||
| Success -> Success
|
||||
;;
|
||||
end
|
||||
|
||||
let name = "progress"
|
||||
|
||||
let v1 =
|
||||
Decl.Request.make_gen
|
||||
~version:1
|
||||
~req:Id.sexp
|
||||
~resp:(Conv.option V1.sexp)
|
||||
~upgrade_req:Fun.id
|
||||
~downgrade_req:Fun.id
|
||||
~upgrade_resp:(Option.map ~f:V1.to_progress)
|
||||
~downgrade_resp:(Option.map ~f:V1.of_progress)
|
||||
;;
|
||||
|
||||
let v2 =
|
||||
Decl.Request.make_current_gen
|
||||
~version:2
|
||||
~req:Id.sexp
|
||||
~resp:(Conv.option Progress.sexp)
|
||||
;;
|
||||
end
|
||||
|
||||
module Diagnostic = struct
|
||||
let name = "diagnostic"
|
||||
|
||||
let v1 =
|
||||
Decl.Request.make_gen
|
||||
~version:1
|
||||
~req:Id.sexp
|
||||
~resp:(Conv.option (Conv.list Diagnostics_v1.Event.sexp))
|
||||
~upgrade_req:Fun.id
|
||||
~downgrade_req:Fun.id
|
||||
~upgrade_resp:(Option.map ~f:(List.map ~f:Diagnostics_v1.Event.to_event))
|
||||
~downgrade_resp:(Option.map ~f:(List.map ~f:Diagnostics_v1.Event.of_event))
|
||||
;;
|
||||
|
||||
let v2 =
|
||||
Decl.Request.make_current_gen
|
||||
~version:2
|
||||
~req:Id.sexp
|
||||
~resp:(Conv.option (Conv.list Diagnostic.Event.sexp))
|
||||
;;
|
||||
end
|
||||
|
||||
module Job = struct
|
||||
let name = "running-jobs"
|
||||
|
||||
let v1 =
|
||||
Decl.Request.make_current_gen
|
||||
~req:Id.sexp
|
||||
~resp:(Conv.option (Conv.list Job.Event.sexp))
|
||||
~version:1
|
||||
;;
|
||||
end
|
||||
|
||||
let progress =
|
||||
let open Progress in
|
||||
make name [ v1; v2 ]
|
||||
;;
|
||||
|
||||
let diagnostic =
|
||||
let open Diagnostic in
|
||||
make name [ v1; v2 ]
|
||||
;;
|
||||
|
||||
let running_jobs =
|
||||
let open Job in
|
||||
make name [ v1 ]
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
open Types
|
||||
open Exported_types
|
||||
|
||||
module Public : sig
|
||||
val ping : (unit, unit) Decl.Request.t
|
||||
val diagnostics : (unit, Diagnostic.t list) Decl.Request.t
|
||||
val shutdown : unit Decl.Notification.t
|
||||
val format_dune_file : (Path.t * [ `Contents of string ], string) Decl.Request.t
|
||||
val promote : (Path.t, unit) Decl.Request.t
|
||||
val promote_many : (Files_to_promote.t, Build_outcome_with_diagnostics.t) Decl.request
|
||||
val build_dir : (unit, Path.t) Decl.Request.t
|
||||
end
|
||||
|
||||
module Server_side : sig
|
||||
val abort : Message.t Decl.Notification.t
|
||||
val log : Message.t Decl.Notification.t
|
||||
end
|
||||
|
||||
module Poll : sig
|
||||
type 'a t
|
||||
|
||||
val poll : 'a t -> (Id.t, 'a option) Decl.Request.t
|
||||
val cancel : 'a t -> Id.t Decl.Notification.t
|
||||
|
||||
module Name : sig
|
||||
type t
|
||||
|
||||
val make : string -> t
|
||||
val compare : t -> t -> Ordering.t
|
||||
end
|
||||
|
||||
val make : Name.t -> (Id.t, 'a option) Decl.Request.gen list -> 'a t
|
||||
val name : 'a t -> Name.t
|
||||
val progress : Progress.t t
|
||||
val diagnostic : Diagnostic.Event.t list t
|
||||
val running_jobs : Job.Event.t list t
|
||||
end
|
||||
216
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/registry.ml
Normal file
216
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/registry.ml
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
open Import
|
||||
|
||||
module File = struct
|
||||
type t =
|
||||
{ path : string
|
||||
; contents : string
|
||||
}
|
||||
end
|
||||
|
||||
let _pid_of_path path =
|
||||
Filename.basename path
|
||||
|> Filename.chop_suffix_opt ~suffix:".pid"
|
||||
|> Option.bind ~f:Int.of_string
|
||||
;;
|
||||
|
||||
module Dune = struct
|
||||
module T = struct
|
||||
type t =
|
||||
{ root : string
|
||||
; pid : int
|
||||
; where : Where.t
|
||||
}
|
||||
|
||||
let compare t { root; pid; where } =
|
||||
let open Ordering.O in
|
||||
let= () = Int.compare t.pid pid in
|
||||
let= () = String.compare t.root root in
|
||||
Where.compare t.where where
|
||||
;;
|
||||
|
||||
let to_dyn { root; pid; where } =
|
||||
let open Dyn in
|
||||
record [ "root", string root; "pid", int pid; "where", Where.to_dyn where ]
|
||||
;;
|
||||
end
|
||||
|
||||
include T
|
||||
module C = Comparable.Make (T)
|
||||
module Set = C.Set
|
||||
|
||||
let create ~where ~root ~pid = { where; root; pid }
|
||||
let root t = t.root
|
||||
let where t = t.where
|
||||
let pid t = t.pid
|
||||
let filename dune = Printf.sprintf "%d.csexp" dune.pid
|
||||
|
||||
let sexp : t Conv.value =
|
||||
let open Conv in
|
||||
let to_ (where, root, pid) = { where; root; pid } in
|
||||
let from { where; root; pid } = where, root, pid in
|
||||
let where = field "where" (required Where.sexp) in
|
||||
let root = field "root" (required string) in
|
||||
let pid = field "pid" (required int) in
|
||||
iso (record (three where root pid)) to_ from
|
||||
;;
|
||||
|
||||
type error =
|
||||
| Of_sexp of Conv.error
|
||||
| Csexp of
|
||||
{ position : int
|
||||
; message : string
|
||||
}
|
||||
|
||||
exception E of error
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| E (Of_sexp e) -> Some (Dyn.to_string (Conv.dyn_of_error e))
|
||||
| E (Csexp { position; message }) ->
|
||||
Some
|
||||
(Dyn.to_string
|
||||
(let open Dyn in
|
||||
record [ "message", string message; "position", int position ]))
|
||||
| _ -> None)
|
||||
;;
|
||||
|
||||
let of_file (f : File.t) =
|
||||
match Csexp.parse_string f.contents with
|
||||
| Error (position, message) -> Error (Csexp { position; message })
|
||||
| Ok s ->
|
||||
(match Conv.of_sexp sexp ~version:(0, 0) s with
|
||||
| Ok s -> Ok s
|
||||
| Error e -> Error (Of_sexp e))
|
||||
;;
|
||||
end
|
||||
|
||||
module Config = struct
|
||||
type t = Xdg.t
|
||||
|
||||
let watch_dir t =
|
||||
let dir =
|
||||
match Xdg.runtime_dir t with
|
||||
| Some runtime -> runtime
|
||||
| None -> Xdg.data_dir t
|
||||
in
|
||||
Filename.concat dir "dune/rpc"
|
||||
;;
|
||||
|
||||
let create x = x
|
||||
|
||||
let register t dune =
|
||||
let file =
|
||||
let contents = Conv.to_sexp Dune.sexp dune |> Csexp.to_string in
|
||||
let path = Filename.concat (watch_dir t) (Dune.filename dune) in
|
||||
{ File.contents; path }
|
||||
in
|
||||
`Caller_should_write file
|
||||
;;
|
||||
end
|
||||
|
||||
type nonrec t =
|
||||
{ config : Config.t
|
||||
; mutable last_mtime : float option
|
||||
; mutable current : Dune.t list
|
||||
}
|
||||
|
||||
let create config = { config; last_mtime = None; current = [] }
|
||||
let current t = t.current
|
||||
|
||||
module Refresh = struct
|
||||
type t =
|
||||
{ added : Dune.t list
|
||||
; removed : Dune.t list
|
||||
; errored : (string * exn) list
|
||||
}
|
||||
|
||||
let empty = { added = []; removed = []; errored = [] }
|
||||
let added t = t.added
|
||||
let removed t = t.removed
|
||||
let errored t = t.errored
|
||||
end
|
||||
|
||||
module Poll
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(IO : sig
|
||||
val scandir : string -> (string list, exn) result Fiber.t
|
||||
val stat : string -> ([ `Mtime of float ], exn) result Fiber.t
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
end) =
|
||||
struct
|
||||
open Fiber.O
|
||||
|
||||
let ( let** ) x f =
|
||||
let* x = x in
|
||||
match x with
|
||||
| Ok s -> f s
|
||||
| Error e -> Fiber.return (Error e)
|
||||
;;
|
||||
|
||||
let ( let++ ) x f =
|
||||
let+ x = x in
|
||||
match x with
|
||||
| Ok s -> Ok (f s)
|
||||
| Error e -> Error e
|
||||
;;
|
||||
|
||||
let poll t =
|
||||
let dir = Config.watch_dir t.config in
|
||||
let** (`Mtime mtime) = IO.stat dir in
|
||||
let skip =
|
||||
match t.last_mtime with
|
||||
| Some last_mtime -> last_mtime >= mtime
|
||||
| None ->
|
||||
t.last_mtime <- Some mtime;
|
||||
false
|
||||
in
|
||||
if skip
|
||||
then Fiber.return (Ok Refresh.empty)
|
||||
else
|
||||
let++ results =
|
||||
let** contents = IO.scandir dir in
|
||||
let contents =
|
||||
List.filter contents ~f:(fun fname -> fname <> "." && fname <> "..")
|
||||
in
|
||||
let+ res =
|
||||
Fiber.parallel_map contents ~f:(fun fname ->
|
||||
let path = Filename.concat dir fname in
|
||||
let+ contents = IO.read_file path in
|
||||
( path
|
||||
, match contents with
|
||||
| Error e -> Error e
|
||||
| Ok contents ->
|
||||
let file = { File.contents; path } in
|
||||
(match Dune.of_file file with
|
||||
| Ok _ as s -> s
|
||||
| Error e -> Error (Dune.E e)) ))
|
||||
in
|
||||
Ok res
|
||||
in
|
||||
let new_current, errored =
|
||||
List.partition_map results ~f:(fun (file, res) ->
|
||||
match res with
|
||||
| Ok s -> Left s
|
||||
| Error e -> Right (file, e))
|
||||
in
|
||||
let current = t.current in
|
||||
t.current <- new_current;
|
||||
let module Set = Dune.Set in
|
||||
let new_current = Set.of_list new_current in
|
||||
let current = Set.of_list current in
|
||||
{ Refresh.added = Set.to_list (Set.diff new_current current)
|
||||
; removed = Set.to_list (Set.diff current new_current)
|
||||
; errored
|
||||
}
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
module File : sig
|
||||
type t =
|
||||
{ path : string
|
||||
; contents : string
|
||||
}
|
||||
end
|
||||
|
||||
module Dune : sig
|
||||
type t
|
||||
|
||||
val where : t -> Where.t
|
||||
val to_dyn : t -> Dyn.t
|
||||
val compare : t -> t -> Ordering.t
|
||||
val root : t -> string
|
||||
val pid : t -> int
|
||||
val create : where:Where.t -> root:string -> pid:int -> t
|
||||
|
||||
type error =
|
||||
| Of_sexp of Conv.error
|
||||
| Csexp of
|
||||
{ position : int
|
||||
; message : string
|
||||
}
|
||||
|
||||
val of_file : File.t -> (t, error) result
|
||||
end
|
||||
|
||||
module Config : sig
|
||||
type t
|
||||
|
||||
val create : Xdg.t -> t
|
||||
val register : t -> Dune.t -> [ `Caller_should_write of File.t ]
|
||||
val watch_dir : t -> string
|
||||
end
|
||||
|
||||
type t
|
||||
|
||||
val create : Config.t -> t
|
||||
val current : t -> Dune.t list
|
||||
|
||||
module Refresh : sig
|
||||
type t
|
||||
|
||||
val added : t -> Dune.t list
|
||||
val removed : t -> Dune.t list
|
||||
val errored : t -> (string * exn) list
|
||||
end
|
||||
|
||||
module Poll
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(_ : sig
|
||||
val scandir : string -> (string list, exn) result Fiber.t
|
||||
val stat : string -> ([ `Mtime of float ], exn) result Fiber.t
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
end) : sig
|
||||
val poll : t -> (Refresh.t, exn) result Fiber.t
|
||||
end
|
||||
14
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/sub.ml
Normal file
14
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/sub.ml
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
open Types
|
||||
|
||||
type 'a t =
|
||||
{ poll : (Id.t, 'a option) Decl.Request.witness
|
||||
; cancel : Id.t Decl.Notification.witness
|
||||
}
|
||||
|
||||
let of_procedure p =
|
||||
let open Procedures.Poll in
|
||||
{ poll = (poll p).decl; cancel = (cancel p).decl }
|
||||
;;
|
||||
|
||||
let poll t = t.poll
|
||||
let poll_cancel t = t.cancel
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
open Types
|
||||
|
||||
type 'a t
|
||||
|
||||
val of_procedure : 'a Procedures.Poll.t -> 'a t
|
||||
val poll : 'a t -> (Id.t, 'a option) Decl.Request.witness
|
||||
val poll_cancel : 'a t -> Id.t Decl.Notification.witness
|
||||
524
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/types.ml
Normal file
524
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/types.ml
Normal file
|
|
@ -0,0 +1,524 @@
|
|||
open Import
|
||||
|
||||
module Id = struct
|
||||
module T = struct
|
||||
type t = Sexp.t
|
||||
|
||||
let equal = Poly.equal
|
||||
let compare = Poly.compare
|
||||
let to_dyn s = Sexp.to_dyn s
|
||||
end
|
||||
|
||||
include T
|
||||
|
||||
let make s = s
|
||||
let to_sexp t = t
|
||||
let sexp = Conv.sexp
|
||||
let gen f = Conv.field "id" (f sexp)
|
||||
let required_field = gen Conv.required
|
||||
let optional_field = gen Conv.optional
|
||||
let hash = Poly.hash
|
||||
|
||||
module C = Comparable.Make (T)
|
||||
module Set = C.Set
|
||||
module Map = C.Map
|
||||
end
|
||||
|
||||
module Version = struct
|
||||
type t = int * int
|
||||
|
||||
let latest = 3, 20
|
||||
|
||||
let sexp : t Conv.value =
|
||||
let open Conv in
|
||||
pair int int
|
||||
;;
|
||||
end
|
||||
|
||||
module Method = struct
|
||||
module Name = struct
|
||||
type t = string
|
||||
|
||||
let sexp : t Conv.value = Conv.string
|
||||
|
||||
module Map = String.Map
|
||||
module Table = String.Table
|
||||
end
|
||||
|
||||
module Version = struct
|
||||
type t = int
|
||||
|
||||
let sexp = Conv.int
|
||||
|
||||
module Set = Int.Set
|
||||
module Map = Int.Map
|
||||
end
|
||||
end
|
||||
|
||||
module Call = struct
|
||||
type t =
|
||||
{ method_ : Method.Name.t
|
||||
; params : Sexp.t
|
||||
}
|
||||
|
||||
let to_dyn { method_; params } =
|
||||
let open Dyn in
|
||||
record [ "method_", String method_; "params", Sexp.to_dyn params ]
|
||||
;;
|
||||
|
||||
let create ?(params = Sexp.List []) ~method_ () = { method_; params }
|
||||
|
||||
let fields =
|
||||
let open Conv in
|
||||
let to_ (method_, params) = { method_; params } in
|
||||
let from { method_; params } = method_, params in
|
||||
let method_ = field "method" (required Method.Name.sexp) in
|
||||
let params = field "params" (required sexp) in
|
||||
iso (both method_ params) to_ from
|
||||
;;
|
||||
end
|
||||
|
||||
module Request = struct
|
||||
type t = Id.t * Call.t
|
||||
end
|
||||
|
||||
module Response = struct
|
||||
module Error = struct
|
||||
type kind =
|
||||
| Invalid_request
|
||||
| Code_error
|
||||
| Connection_dead
|
||||
|
||||
let dyn_of_kind =
|
||||
let open Dyn in
|
||||
function
|
||||
| Invalid_request -> variant "Invalid_request" []
|
||||
| Code_error -> variant "Code_error" []
|
||||
| Connection_dead -> variant "Connection_dead" []
|
||||
;;
|
||||
|
||||
type t =
|
||||
{ payload : Sexp.t option
|
||||
; message : string
|
||||
; kind : kind
|
||||
}
|
||||
|
||||
let payload t = t.payload
|
||||
let kind t = t.kind
|
||||
let message t = t.message
|
||||
|
||||
exception E of t
|
||||
|
||||
let create ?payload ~kind ~message () = { payload; message; kind }
|
||||
|
||||
let of_conv (error : Conv.error) =
|
||||
let make_payload = function
|
||||
| [] -> None
|
||||
| payload -> Some (Sexp.record payload)
|
||||
in
|
||||
match error with
|
||||
| Parse_error { payload; message } ->
|
||||
{ message; payload = make_payload payload; kind = Invalid_request }
|
||||
| Version_error { payload; message; since = _; until = _ } ->
|
||||
(* cwong: Should we even still include this? *)
|
||||
{ message; payload = make_payload payload; kind = Code_error }
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let id = field "payload" (optional sexp) in
|
||||
let message = field "message" (required string) in
|
||||
let kind =
|
||||
field
|
||||
"kind"
|
||||
(required
|
||||
(enum [ "Invalid_request", Invalid_request; "Code_error", Code_error ]))
|
||||
in
|
||||
record
|
||||
(iso
|
||||
(three id message kind)
|
||||
(fun (payload, message, kind) -> { payload; message; kind })
|
||||
(fun { payload; message; kind } -> payload, message, kind))
|
||||
;;
|
||||
|
||||
let to_dyn { payload; message; kind } =
|
||||
let open Dyn in
|
||||
record
|
||||
[ "payload", option Sexp.to_dyn payload
|
||||
; "message", string message
|
||||
; "kind", dyn_of_kind kind
|
||||
]
|
||||
;;
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| E e -> Some (Dyn.to_string (Dyn.variant "Response.E" [ to_dyn e ]))
|
||||
| _ -> None)
|
||||
;;
|
||||
end
|
||||
|
||||
type t = (Sexp.t, Error.t) result
|
||||
|
||||
let result =
|
||||
let open Conv in
|
||||
let ok = constr "ok" sexp (fun x -> Ok x) in
|
||||
let error = constr "error" Error.sexp (fun x -> Error x) in
|
||||
sum
|
||||
[ econstr ok; econstr error ]
|
||||
(function
|
||||
| Ok s -> case s ok
|
||||
| Error e -> case e error)
|
||||
;;
|
||||
|
||||
let fields =
|
||||
let open Conv in
|
||||
let id = Id.required_field in
|
||||
let payload = field "result" (required result) in
|
||||
both id payload
|
||||
;;
|
||||
|
||||
let to_dyn = Result.to_dyn Sexp.to_dyn Error.to_dyn
|
||||
end
|
||||
|
||||
module Protocol = struct
|
||||
type t = int
|
||||
|
||||
let latest_version = 0
|
||||
let sexp = Conv.int
|
||||
end
|
||||
|
||||
module Initialize = struct
|
||||
module Request = struct
|
||||
type t =
|
||||
{ dune_version : Version.t
|
||||
; protocol_version : Protocol.t
|
||||
; id : Id.t
|
||||
}
|
||||
|
||||
let dune_version t = t.dune_version
|
||||
let protocol_version t = t.protocol_version
|
||||
let id t = t.id
|
||||
|
||||
let create ~id =
|
||||
let dune_version = Version.latest in
|
||||
let protocol_version = Protocol.latest_version in
|
||||
{ dune_version; protocol_version; id }
|
||||
;;
|
||||
|
||||
let method_name = "initialize"
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let dune_version = field "dune_version" (required Version.sexp) in
|
||||
let protocol_version = field "protocol_version" (required Protocol.sexp) in
|
||||
let id = Id.required_field in
|
||||
let to_ (dune_version, protocol_version, id) =
|
||||
{ dune_version; protocol_version; id }
|
||||
in
|
||||
let from { dune_version; protocol_version; id } =
|
||||
dune_version, protocol_version, id
|
||||
in
|
||||
record (iso (three dune_version protocol_version id) to_ from)
|
||||
;;
|
||||
|
||||
let of_call { Call.method_; params } ~version =
|
||||
if String.equal method_ method_name
|
||||
then Conv.of_sexp sexp ~version params |> Result.map_error ~f:Response.Error.of_conv
|
||||
else (
|
||||
let message = "initialize request expected" in
|
||||
Error (Response.Error.create ~message ~kind:Invalid_request ()))
|
||||
;;
|
||||
|
||||
let to_call t =
|
||||
let params = Conv.to_sexp sexp t in
|
||||
{ Call.method_ = "initialize"; params }
|
||||
;;
|
||||
end
|
||||
|
||||
module Response = struct
|
||||
type t = unit
|
||||
|
||||
let sexp = Conv.unit
|
||||
let create () = ()
|
||||
let to_response t = Conv.to_sexp sexp t
|
||||
end
|
||||
end
|
||||
|
||||
module Version_negotiation = struct
|
||||
module Request = struct
|
||||
type t = Menu of (Method.Name.t * Method.Version.t list) list
|
||||
|
||||
let method_name = "version_menu"
|
||||
let create menu = Menu menu
|
||||
|
||||
let sexp =
|
||||
Conv.(
|
||||
iso
|
||||
(list (pair Method.Name.sexp (list Method.Version.sexp)))
|
||||
(fun x -> Menu x)
|
||||
(function Menu x -> x))
|
||||
;;
|
||||
|
||||
let to_call t =
|
||||
let params = Conv.to_sexp sexp t in
|
||||
{ Call.method_ = method_name; params }
|
||||
;;
|
||||
|
||||
let of_call { Call.method_; params } ~version =
|
||||
if String.equal method_ method_name
|
||||
then Conv.of_sexp sexp ~version params |> Result.map_error ~f:Response.Error.of_conv
|
||||
else (
|
||||
let message = "version negotiation request expected" in
|
||||
Error (Response.Error.create ~message ~kind:Invalid_request ()))
|
||||
;;
|
||||
end
|
||||
|
||||
module Response = struct
|
||||
type t = Selected of (Method.Name.t * Method.Version.t) list
|
||||
|
||||
let sexp =
|
||||
Conv.(
|
||||
iso
|
||||
(list (pair Method.Name.sexp Method.Version.sexp))
|
||||
(fun x -> Selected x)
|
||||
(function Selected x -> x))
|
||||
;;
|
||||
|
||||
let create x = Selected x
|
||||
let to_response t = Conv.to_sexp sexp t
|
||||
end
|
||||
end
|
||||
|
||||
module Persistent = struct
|
||||
module Out = struct
|
||||
type t =
|
||||
| Packet of Sexp.t
|
||||
| Close_connection
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let packet = constr "packet" sexp (fun p -> Packet p) in
|
||||
let close_connection =
|
||||
constr "close_connection" unit (fun () -> Close_connection)
|
||||
in
|
||||
sum
|
||||
[ econstr packet; econstr close_connection ]
|
||||
(function
|
||||
| Packet p -> case p packet
|
||||
| Close_connection -> case () close_connection)
|
||||
;;
|
||||
end
|
||||
|
||||
module In = struct
|
||||
type t =
|
||||
| New_connection
|
||||
| Packet of Csexp.t
|
||||
| Close_connection
|
||||
|
||||
let to_dyn =
|
||||
let open Dyn in
|
||||
function
|
||||
| New_connection -> variant "New_connection" []
|
||||
| Close_connection -> variant "Close_connection" []
|
||||
| Packet sexp -> variant "Packet" [ Sexp.to_dyn sexp ]
|
||||
;;
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let new_connection = constr "new_connection" unit (fun () -> New_connection) in
|
||||
let packet = constr "packet" sexp (fun p -> Packet p) in
|
||||
let close_connection =
|
||||
constr "close_connection" unit (fun () -> Close_connection)
|
||||
in
|
||||
sum
|
||||
[ econstr new_connection; econstr packet; econstr close_connection ]
|
||||
(function
|
||||
| New_connection -> case () new_connection
|
||||
| Packet p -> case p packet
|
||||
| Close_connection -> case () close_connection)
|
||||
;;
|
||||
end
|
||||
end
|
||||
|
||||
module Packet = struct
|
||||
type t =
|
||||
| Request of Request.t
|
||||
| Response of (Id.t * Response.t)
|
||||
| Notification of Call.t
|
||||
|
||||
let sexp =
|
||||
let open Conv in
|
||||
let to_ (id, result, call) =
|
||||
match id, result, call with
|
||||
| Some id, None, Some call -> Request (id, call)
|
||||
| None, None, Some call -> Notification call
|
||||
| Some id, Some result, None -> Response (id, result)
|
||||
| _, _, _ -> Conv.error (Parse_error { message = "invalid packet"; payload = [] })
|
||||
in
|
||||
let from = function
|
||||
| Request (id, payload) -> Some id, None, Some payload
|
||||
| Response (id, response) -> Some id, Some response, None
|
||||
| Notification call -> None, None, Some call
|
||||
in
|
||||
record
|
||||
@@ iso
|
||||
(let id = Id.optional_field in
|
||||
let result = field "result" (optional Response.result) in
|
||||
let method_ = field "method" (optional Method.Name.sexp) in
|
||||
let params = field "params" (optional sexp) in
|
||||
let call =
|
||||
iso
|
||||
(both method_ params)
|
||||
(fun (method_, params) ->
|
||||
match method_, params with
|
||||
| Some method_, Some params -> Some { Call.method_; params }
|
||||
| None, None -> None
|
||||
| Some _, None | None, Some _ ->
|
||||
Conv.error (Parse_error { message = "invalid call"; payload = [] }))
|
||||
(function
|
||||
| Some { Call.method_; params } -> Some method_, Some params
|
||||
| None -> None, None)
|
||||
in
|
||||
three id result call)
|
||||
to_
|
||||
from
|
||||
;;
|
||||
end
|
||||
|
||||
module Decl = struct
|
||||
type 'gen t =
|
||||
{ method_ : Method.Name.t
|
||||
; key : 'gen Method.Version.Map.t Univ_map.Key.t
|
||||
}
|
||||
|
||||
module Generation = struct
|
||||
type ('wire_req, 'wire_resp, 'real_req, 'real_resp) conv =
|
||||
{ req : 'wire_req Conv.value
|
||||
; resp : 'wire_resp Conv.value
|
||||
; upgrade_req : 'wire_req -> 'real_req
|
||||
; downgrade_req : 'real_req -> 'wire_req
|
||||
; upgrade_resp : 'wire_resp -> 'real_resp
|
||||
; downgrade_resp : 'real_resp -> 'wire_resp
|
||||
}
|
||||
|
||||
type (_, _) t =
|
||||
| T :
|
||||
('wire_req, 'wire_resp, 'real_req, 'real_resp) conv
|
||||
-> ('real_req, 'real_resp) t
|
||||
end
|
||||
|
||||
module Request = struct
|
||||
type ('req, 'resp) gen = Method.Version.t * ('req, 'resp) Generation.t
|
||||
|
||||
let make_gen
|
||||
~req
|
||||
~resp
|
||||
~upgrade_req
|
||||
~downgrade_req
|
||||
~upgrade_resp
|
||||
~downgrade_resp
|
||||
~version
|
||||
=
|
||||
( version
|
||||
, Generation.T
|
||||
{ req; resp; upgrade_req; downgrade_req; upgrade_resp; downgrade_resp } )
|
||||
;;
|
||||
|
||||
let make_current_gen ~req ~resp ~version =
|
||||
make_gen
|
||||
~req
|
||||
~resp
|
||||
~upgrade_req:Fun.id
|
||||
~downgrade_req:Fun.id
|
||||
~upgrade_resp:Fun.id
|
||||
~downgrade_resp:Fun.id
|
||||
~version
|
||||
;;
|
||||
|
||||
let gen_to_dyn _ = Dyn.String "<generation>"
|
||||
|
||||
type ('req, 'resp) witness = ('req, 'resp) Generation.t t
|
||||
|
||||
type nonrec ('req, 'resp) t =
|
||||
{ decl : ('req, 'resp) witness
|
||||
; generations : ('req, 'resp) gen list
|
||||
}
|
||||
|
||||
let make ~method_ ~generations =
|
||||
{ generations
|
||||
; decl =
|
||||
{ method_; key = Univ_map.Key.create ~name:method_ (Int.Map.to_dyn gen_to_dyn) }
|
||||
}
|
||||
;;
|
||||
|
||||
let print_generation_list ~include_response generations =
|
||||
List.iter generations ~f:(fun (version, Generation.T conv) ->
|
||||
let conv_to_digest conv =
|
||||
let sexp_string = Sexp.to_string (Conv.sexp_for_digest conv) in
|
||||
if String.length sexp_string < 32
|
||||
then sexp_string
|
||||
else Digest.to_hex (Digest.string sexp_string)
|
||||
in
|
||||
let req = conv_to_digest conv.req in
|
||||
let resp = conv_to_digest conv.resp in
|
||||
if include_response
|
||||
then Printf.printf "Version %d:\n Request: %s\n Response: %s\n" version req resp
|
||||
else Printf.printf "Version %d: %s\n" version req)
|
||||
;;
|
||||
|
||||
let print_generations t = print_generation_list ~include_response:true t.generations
|
||||
let witness t = t.decl
|
||||
end
|
||||
|
||||
module Notification = struct
|
||||
type 'payload gen = Method.Version.t * ('payload, unit) Generation.t
|
||||
|
||||
let make_gen
|
||||
(type a b)
|
||||
~(conv : a Conv.value)
|
||||
~(upgrade : a -> b)
|
||||
~(downgrade : b -> a)
|
||||
~version
|
||||
: b gen
|
||||
=
|
||||
( version
|
||||
, Generation.T
|
||||
{ req = conv
|
||||
; resp = Conv.unit
|
||||
; upgrade_req = upgrade
|
||||
; downgrade_req = downgrade
|
||||
; upgrade_resp = Fun.id
|
||||
; downgrade_resp = Fun.id
|
||||
} )
|
||||
;;
|
||||
|
||||
let make_current_gen (type a) ~(conv : a Conv.value) ~version : a gen =
|
||||
make_gen ~conv ~upgrade:Fun.id ~downgrade:Fun.id ~version
|
||||
;;
|
||||
|
||||
let gen_to_dyn _ = Dyn.String "<generation>"
|
||||
|
||||
type 'payload witness = ('payload, unit) Generation.t t
|
||||
|
||||
type nonrec 'payload t =
|
||||
{ decl : 'payload witness
|
||||
; generations : 'payload gen list
|
||||
}
|
||||
|
||||
let make ~method_ ~generations =
|
||||
{ generations
|
||||
; decl =
|
||||
{ method_; key = Univ_map.Key.create ~name:method_ (Int.Map.to_dyn gen_to_dyn) }
|
||||
}
|
||||
;;
|
||||
|
||||
let print_generations t =
|
||||
Request.print_generation_list ~include_response:false t.generations
|
||||
;;
|
||||
|
||||
let witness t = t.decl
|
||||
end
|
||||
|
||||
type ('a, 'b) request = ('a, 'b) Request.t
|
||||
type 'a notification = 'a Notification.t
|
||||
end
|
||||
258
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/types.mli
Normal file
258
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/types.mli
Normal file
|
|
@ -0,0 +1,258 @@
|
|||
open Import
|
||||
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val make : Sexp.t -> t
|
||||
val sexp : (t, Conv.values) Conv.t
|
||||
val required_field : (t, Conv.fields) Conv.t
|
||||
val optional_field : (t option, Conv.fields) Conv.t
|
||||
val to_dyn : t -> Dyn.t
|
||||
val hash : t -> int
|
||||
val equal : t -> t -> bool
|
||||
val to_sexp : t -> Sexp.t
|
||||
|
||||
include Comparable_intf.S with type key := t
|
||||
end
|
||||
|
||||
module Version : sig
|
||||
type t = int * int
|
||||
|
||||
val latest : t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Method : sig
|
||||
module Name : sig
|
||||
type t = string
|
||||
|
||||
val sexp : t Conv.value
|
||||
|
||||
module Map = String.Map
|
||||
module Table = String.Table
|
||||
end
|
||||
|
||||
module Version : sig
|
||||
type t = int
|
||||
|
||||
val sexp : t Conv.value
|
||||
|
||||
module Set = Int.Set
|
||||
module Map = Int.Map
|
||||
end
|
||||
end
|
||||
|
||||
module Call : sig
|
||||
(** Represents a single rpc call. Request or notification. *)
|
||||
|
||||
type t =
|
||||
{ method_ : Method.Name.t
|
||||
; params : Sexp.t
|
||||
}
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val create : ?params:Sexp.t -> method_:Method.Name.t -> unit -> t
|
||||
val fields : (t, Conv.fields) Conv.t
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
module Error : sig
|
||||
type kind =
|
||||
| Invalid_request
|
||||
| Code_error
|
||||
| Connection_dead
|
||||
|
||||
type t =
|
||||
{ payload : Sexp.t option
|
||||
; message : string
|
||||
; kind : kind
|
||||
}
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val payload : t -> Sexp.t option
|
||||
val message : t -> string
|
||||
val kind : t -> kind
|
||||
|
||||
exception E of t
|
||||
|
||||
val create : ?payload:Sexp.t -> kind:kind -> message:string -> unit -> t
|
||||
val of_conv : Conv.error -> t
|
||||
end
|
||||
|
||||
type t = (Sexp.t, Error.t) result
|
||||
|
||||
val fields : (Id.t * t, Conv.fields) Conv.t
|
||||
val to_dyn : t -> Dyn.t
|
||||
end
|
||||
|
||||
module Request : sig
|
||||
type t = Id.t * Call.t
|
||||
end
|
||||
|
||||
module Protocol : sig
|
||||
type t = int
|
||||
|
||||
val latest_version : t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Initialize : sig
|
||||
module Request : sig
|
||||
type t =
|
||||
{ dune_version : int * int
|
||||
; protocol_version : int
|
||||
; id : Id.t
|
||||
}
|
||||
|
||||
val create : id:Id.t -> t
|
||||
val of_call : Call.t -> version:int * int -> (t, Response.Error.t) result
|
||||
val dune_version : t -> int * int
|
||||
val protocol_version : t -> int
|
||||
val id : t -> Id.t
|
||||
val to_call : t -> Call.t
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
type t
|
||||
|
||||
val create : unit -> t
|
||||
val to_response : t -> Sexp.t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module Version_negotiation : sig
|
||||
module Request : sig
|
||||
type t = private Menu of (Method.Name.t * Method.Version.t list) list
|
||||
|
||||
val create : (Method.Name.t * Method.Version.t list) list -> t
|
||||
val sexp : t Conv.value
|
||||
val to_call : t -> Call.t
|
||||
val of_call : Call.t -> version:Version.t -> (t, Response.Error.t) result
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
type t = private Selected of (string * int) list
|
||||
|
||||
val create : (string * int) list -> t
|
||||
val to_response : t -> Sexp.t
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module Persistent : sig
|
||||
module In : sig
|
||||
type t =
|
||||
| New_connection
|
||||
| Packet of Csexp.t
|
||||
| Close_connection
|
||||
|
||||
val sexp : t Conv.value
|
||||
val to_dyn : t -> Dyn.t
|
||||
end
|
||||
|
||||
module Out : sig
|
||||
type t =
|
||||
| Packet of Sexp.t
|
||||
| Close_connection
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
end
|
||||
|
||||
module Packet : sig
|
||||
type t =
|
||||
| Request of Request.t
|
||||
| Response of (Id.t * Response.t)
|
||||
| Notification of Call.t
|
||||
|
||||
val sexp : t Conv.value
|
||||
end
|
||||
|
||||
module Decl : sig
|
||||
type 'gen t =
|
||||
{ method_ : Method.Name.t
|
||||
; key : 'gen Method.Version.Map.t Univ_map.Key.t
|
||||
}
|
||||
|
||||
module Generation : sig
|
||||
type ('wire_req, 'wire_resp, 'real_req, 'real_resp) conv =
|
||||
{ req : 'wire_req Conv.value
|
||||
; resp : 'wire_resp Conv.value
|
||||
; upgrade_req : 'wire_req -> 'real_req
|
||||
; downgrade_req : 'real_req -> 'wire_req
|
||||
; upgrade_resp : 'wire_resp -> 'real_resp
|
||||
; downgrade_resp : 'real_resp -> 'wire_resp
|
||||
}
|
||||
|
||||
type (_, _) t =
|
||||
| T :
|
||||
('wire_req, 'wire_resp, 'real_req, 'real_resp) conv
|
||||
-> ('real_req, 'real_resp) t
|
||||
end
|
||||
|
||||
module Request : sig
|
||||
type ('req, 'resp) gen = Method.Version.t * ('req, 'resp) Generation.t
|
||||
|
||||
val make_gen
|
||||
: req:'wire_req Conv.value
|
||||
-> resp:'wire_resp Conv.value
|
||||
-> upgrade_req:('wire_req -> 'req)
|
||||
-> downgrade_req:('req -> 'wire_req)
|
||||
-> upgrade_resp:('wire_resp -> 'resp)
|
||||
-> downgrade_resp:('resp -> 'wire_resp)
|
||||
-> version:Method.Version.t
|
||||
-> ('req, 'resp) gen
|
||||
|
||||
val make_current_gen
|
||||
: req:'req Conv.value
|
||||
-> resp:'resp Conv.value
|
||||
-> version:Method.Version.t
|
||||
-> ('req, 'resp) gen
|
||||
|
||||
type ('req, 'resp) witness = ('req, 'resp) Generation.t t
|
||||
|
||||
type nonrec ('req, 'resp) t =
|
||||
{ decl : ('req, 'resp) witness
|
||||
; generations : ('req, 'resp) gen list
|
||||
}
|
||||
|
||||
val make
|
||||
: method_:Method.Name.t
|
||||
-> generations:('req, 'resp) gen list
|
||||
-> ('req, 'resp) t
|
||||
|
||||
val print_generations : ('req, 'resp) t -> unit
|
||||
val witness : ('a, 'b) t -> ('a, 'b) witness
|
||||
end
|
||||
|
||||
module Notification : sig
|
||||
type 'payload gen = Method.Version.t * ('payload, unit) Generation.t
|
||||
|
||||
val make_gen
|
||||
: conv:'wire Conv.value
|
||||
-> upgrade:('wire -> 'model)
|
||||
-> downgrade:('model -> 'wire)
|
||||
-> version:Method.Version.t
|
||||
-> 'model gen
|
||||
|
||||
val make_current_gen
|
||||
: conv:'model Conv.value
|
||||
-> version:Method.Version.t
|
||||
-> 'model gen
|
||||
|
||||
type 'payload witness = ('payload, unit) Generation.t t
|
||||
|
||||
type nonrec 'payload t =
|
||||
{ decl : 'payload witness
|
||||
; generations : 'payload gen list
|
||||
}
|
||||
|
||||
val make : method_:Method.Name.t -> generations:'payload gen list -> 'payload t
|
||||
val print_generations : 'payload t -> unit
|
||||
val witness : 'a t -> 'a witness
|
||||
end
|
||||
|
||||
type ('a, 'b) request = ('a, 'b) Request.t
|
||||
type 'a notification = 'a Notification.t
|
||||
end
|
||||
|
|
@ -0,0 +1,546 @@
|
|||
open Import
|
||||
open Types
|
||||
|
||||
module Version_error = struct
|
||||
type t =
|
||||
{ payload : Csexp.t option
|
||||
; message : string
|
||||
}
|
||||
|
||||
let payload t = t.payload
|
||||
let message t = t.message
|
||||
|
||||
let to_dyn { payload; message } =
|
||||
Dyn.record
|
||||
[ "message", Dyn.string message; "payload", Dyn.(option Sexp.to_dyn) payload ]
|
||||
;;
|
||||
|
||||
let create ?payload ~message () = { payload; message }
|
||||
|
||||
exception E of t
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| E { payload; message } ->
|
||||
Some
|
||||
(let messages =
|
||||
match payload with
|
||||
| None -> []
|
||||
| Some payload -> [ Sexp.pp payload ]
|
||||
in
|
||||
Format.asprintf "%a@." Pp.to_fmt
|
||||
@@ Pp.concat
|
||||
@@ (Pp.textf "Version_error: %s" message :: messages))
|
||||
| _ -> None)
|
||||
;;
|
||||
|
||||
let to_response_error { payload; message } =
|
||||
Response.Error.create ~kind:Invalid_request ?payload ~message ()
|
||||
;;
|
||||
end
|
||||
|
||||
module Staged = struct
|
||||
type ('req, 'resp) request =
|
||||
{ encode_req : 'req -> Call.t
|
||||
; decode_resp : Csexp.t -> ('resp, Response.Error.t) result
|
||||
}
|
||||
|
||||
type 'payload notification = { encode : 'payload -> Call.t }
|
||||
end
|
||||
|
||||
let raise_version_bug ~method_ ~selected ~verb ~known =
|
||||
Code_error.raise
|
||||
"bug with version negotiation; selected bad method version"
|
||||
[ "message", Dyn.String ("version is " ^ verb)
|
||||
; "method", Dyn.String method_
|
||||
; "implemented versions", Dyn.list Dyn.int known
|
||||
; "selected version", Dyn.Int selected
|
||||
]
|
||||
;;
|
||||
|
||||
(* Pack a universal map key. See below. We can afford to erase the type of
|
||||
the key, because we only care about the keyset of the stored generation
|
||||
listing. *)
|
||||
type packed = T : 'a Method.Version.Map.t Univ_map.Key.t -> packed
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
module Handler : sig
|
||||
type 'state t
|
||||
|
||||
val handle_request : 'state t -> 'state -> Request.t -> Response.t fiber
|
||||
|
||||
val handle_notification
|
||||
: 'state t
|
||||
-> 'state
|
||||
-> Call.t
|
||||
-> (unit, Response.Error.t) result fiber
|
||||
|
||||
val prepare_request
|
||||
: 'a t
|
||||
-> ('req, 'resp) Decl.Request.witness
|
||||
-> (('req, 'resp) Staged.request, Version_error.t) result
|
||||
|
||||
val prepare_notification
|
||||
: 'a t
|
||||
-> 'payload Decl.Notification.witness
|
||||
-> ('payload Staged.notification, Version_error.t) result
|
||||
end
|
||||
|
||||
module Builder : sig
|
||||
type 'state t
|
||||
|
||||
val to_handler
|
||||
: 'state t
|
||||
-> session_version:('state -> Version.t)
|
||||
-> menu:Menu.t
|
||||
-> 'state Handler.t
|
||||
|
||||
val create : unit -> 'state t
|
||||
val registered_procedures : 'a t -> (Method.Name.t * Method.Version.t list) list
|
||||
val declare_notification : 'state t -> 'payload Decl.notification -> unit
|
||||
val declare_request : 'state t -> ('req, 'resp) Decl.request -> unit
|
||||
|
||||
val implement_notification
|
||||
: 'state t
|
||||
-> 'payload Decl.notification
|
||||
-> ('state -> 'payload -> unit fiber)
|
||||
-> unit
|
||||
|
||||
val implement_request
|
||||
: 'state t
|
||||
-> ('req, 'resp) Decl.request
|
||||
-> ('state -> 'req -> 'resp fiber)
|
||||
-> unit
|
||||
end
|
||||
end
|
||||
|
||||
module Make (Fiber : Fiber_intf.S) = struct
|
||||
module Handler = struct
|
||||
type 'state t =
|
||||
{ menu : Menu.t
|
||||
; handle_request : Menu.t -> 'state -> Types.Request.t -> Response.t Fiber.t
|
||||
; handle_notification :
|
||||
Menu.t -> 'state -> Call.t -> (unit, Response.Error.t) result Fiber.t
|
||||
; prepare_request :
|
||||
'req 'resp.
|
||||
Menu.t
|
||||
-> ('req, 'resp) Decl.Request.witness
|
||||
-> (('req, 'resp) Staged.request, Version_error.t) result
|
||||
; prepare_notification :
|
||||
'a.
|
||||
Menu.t
|
||||
-> 'a Decl.Notification.witness
|
||||
-> ('a Staged.notification, Version_error.t) result
|
||||
}
|
||||
|
||||
let handle_request t = t.handle_request t.menu
|
||||
let handle_notification t = t.handle_notification t.menu
|
||||
let prepare_request t = t.prepare_request t.menu
|
||||
let prepare_notification t = t.prepare_notification t.menu
|
||||
end
|
||||
|
||||
(* TODO: This module involves some convoluted and difficult-to-understand
|
||||
types, with multiple levels of GADTs and type packing, in the
|
||||
(possibly-misguided) twin aims of ensuring type safety and maximizing reuse
|
||||
of the actual generation management code. *)
|
||||
module Builder = struct
|
||||
open Decl
|
||||
|
||||
(* A [('req, 'resp) Decl.Generation.t] contains the information necessary to
|
||||
convert from a [Csexp.t] to a ['req]. The [_handler] packings are to
|
||||
enable storing the callbacks in a homogeneous data structure (namely, the
|
||||
[Method.Name.Table.t]. It's alright to erase these types, because these
|
||||
callbacks are intended to be used by the receiving endpoint, which only
|
||||
sees a [Csexp.t], and we only discover the correct type to deserialize to
|
||||
at runtime. *)
|
||||
type 's r_handler =
|
||||
| R :
|
||||
('s -> 'req -> 'resp Fiber.t) * ('req, 'resp) Decl.Generation.t
|
||||
-> 's r_handler
|
||||
|
||||
type 's n_handler =
|
||||
| N :
|
||||
('s -> 'payload -> unit Fiber.t) * ('payload, unit) Decl.Generation.t
|
||||
-> 's n_handler
|
||||
|
||||
(* The declarations and implementations serve dual purposes with dual
|
||||
requirements.
|
||||
|
||||
When storing implementations, we erase the type of the callback, because
|
||||
we cannot know what type to deserialize to until runtime, and so all that
|
||||
matters is whether some handler with the correct type exists.
|
||||
|
||||
On the other hand, declarations must keep some type information in an
|
||||
externally-retrievable way. This is because when invoking an RPC of type
|
||||
[('req, 'resp)], we are *given* a value of type ['req], so the object
|
||||
being stored in the map cannot have its type erased. Instead, we use a
|
||||
[Univ_map] (with the key being stored in the [Decl.t]) so we can retrieve
|
||||
a correctly-typed [Generation.t] mapping later.
|
||||
|
||||
However, unlike a string table, the use of a [Univ_map.t] means that we
|
||||
cannot examine the map alone to get a list of all declared procedures and
|
||||
versions. This is bad, because we need that information to perform
|
||||
version negotiation for the session. To resolve this, we also keep a
|
||||
mapping of all known keys and their associated method names, which we use
|
||||
to construct the initial version menu, then discard. *)
|
||||
type 'state t =
|
||||
{ mutable declared_requests : packed list Method.Name.Map.t * Univ_map.t
|
||||
; mutable declared_notifications : packed list Method.Name.Map.t * Univ_map.t
|
||||
; implemented_requests : 'state r_handler Method.Version.Map.t Method.Name.Table.t
|
||||
; implemented_notifications :
|
||||
'state n_handler Method.Version.Map.t Method.Name.Table.t
|
||||
}
|
||||
|
||||
(* A [('state, 'key, 'output) field_witness] is a first-class representation
|
||||
of a field of a ['state t]. Each field is morally a mutable table holding
|
||||
['output Method.Version.Map.t]s (mapping generation numbers to
|
||||
['output]s), indexed by ['key]s.
|
||||
|
||||
The mental model isn't strictly correct (mostly due to needing the "all
|
||||
known registered keys" hack described above), but is accurate enough that
|
||||
the types of [get] and [set] below should become readable.
|
||||
|
||||
By doing things this way, we can abstract away the logic of
|
||||
|
||||
- Checking the corresponding registry (the declarations table when
|
||||
implementing, and vice versa) for duplicate entries
|
||||
|
||||
- Checking the provided generation listings for overlap
|
||||
|
||||
and
|
||||
|
||||
- Looking up a method name and generation number
|
||||
|
||||
from the type-erasure implementation shenanigans described above, letting
|
||||
all related operations (declaring, implementing, dispatching) share
|
||||
uniform implementations as much as possible. *)
|
||||
type (_, _, _) field_witness =
|
||||
| Declared_requests :
|
||||
( _
|
||||
, Method.Name.t
|
||||
* ('req, 'resp) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t
|
||||
, ('req, 'resp) Decl.Generation.t )
|
||||
field_witness
|
||||
| Declared_notifs :
|
||||
( _
|
||||
, Method.Name.t
|
||||
* ('a, unit) Decl.Generation.t Method.Version.Map.t Univ_map.Key.t
|
||||
, ('a, unit) Decl.Generation.t )
|
||||
field_witness
|
||||
| Impl_requests : ('state, string, 'state r_handler) field_witness
|
||||
| Impl_notifs : ('state, string, 'state n_handler) field_witness
|
||||
|
||||
let get (type st a b) (t : st t) (witness : (st, a, b) field_witness) (key : a)
|
||||
: b Method.Version.Map.t option
|
||||
=
|
||||
match witness with
|
||||
| Declared_requests ->
|
||||
let _, key = key in
|
||||
let _, table = t.declared_requests in
|
||||
Univ_map.find table key
|
||||
| Declared_notifs ->
|
||||
let _, key = key in
|
||||
let _, table = t.declared_notifications in
|
||||
Univ_map.find table key
|
||||
| Impl_requests -> Method.Name.Table.find t.implemented_requests key
|
||||
| Impl_notifs -> Method.Name.Table.find t.implemented_notifications key
|
||||
;;
|
||||
|
||||
let set
|
||||
(type st a b)
|
||||
(t : st t)
|
||||
(witness : (st, a, b) field_witness)
|
||||
(key : a)
|
||||
(value : b Method.Version.Map.t)
|
||||
=
|
||||
match witness with
|
||||
| Declared_requests ->
|
||||
let name, key = key in
|
||||
let known_keys, table = t.declared_requests in
|
||||
t.declared_requests
|
||||
<- Method.Name.Map.add_multi known_keys name (T key), Univ_map.set table key value
|
||||
| Declared_notifs ->
|
||||
let name, key = key in
|
||||
let known_keys, table = t.declared_notifications in
|
||||
t.declared_notifications
|
||||
<- Method.Name.Map.add_multi known_keys name (T key), Univ_map.set table key value
|
||||
| Impl_requests -> Method.Name.Table.set t.implemented_requests key value
|
||||
| Impl_notifs -> Method.Name.Table.set t.implemented_notifications key value
|
||||
;;
|
||||
|
||||
let registered_procedures
|
||||
{ declared_requests = declared_request_keys, declared_request_table
|
||||
; declared_notifications =
|
||||
declared_notification_keys, declared_notification_table
|
||||
; implemented_requests
|
||||
; implemented_notifications
|
||||
}
|
||||
=
|
||||
let batch_declarations which declared_keys declaration_table =
|
||||
Method.Name.Map.foldi declared_keys ~init:[] ~f:(fun name keys acc ->
|
||||
let generations =
|
||||
List.fold_left keys ~init:[] ~f:(fun acc (T key) ->
|
||||
match Univ_map.find declaration_table key with
|
||||
| Some listing -> Method.Version.Map.keys listing @ acc
|
||||
| None ->
|
||||
Code_error.raise
|
||||
"versioning: method found in versioning table without actually being \
|
||||
declared"
|
||||
[ "method_", Dyn.String name
|
||||
; "table", Dyn.String ("known_" ^ which ^ "_table")
|
||||
])
|
||||
in
|
||||
(name, generations) :: acc)
|
||||
in
|
||||
let declared_requests =
|
||||
batch_declarations "request" declared_request_keys declared_request_table
|
||||
in
|
||||
let declared_notifications =
|
||||
batch_declarations
|
||||
"notification"
|
||||
declared_notification_keys
|
||||
declared_notification_table
|
||||
in
|
||||
let batch_implementations table =
|
||||
Method.Name.Table.foldi table ~init:[] ~f:(fun name listing acc ->
|
||||
(name, Method.Version.Map.keys listing) :: acc)
|
||||
in
|
||||
let implemented_requests = batch_implementations implemented_requests in
|
||||
let implemented_notifications = batch_implementations implemented_notifications in
|
||||
List.concat
|
||||
[ declared_requests
|
||||
; declared_notifications
|
||||
; implemented_requests
|
||||
; implemented_notifications
|
||||
]
|
||||
;;
|
||||
|
||||
let create () =
|
||||
let declared_requests = Method.Name.Map.empty, Univ_map.empty in
|
||||
let declared_notifications = Method.Name.Map.empty, Univ_map.empty in
|
||||
let implemented_requests = Method.Name.Table.create 16 in
|
||||
let implemented_notifications = Method.Name.Table.create 16 in
|
||||
{ declared_requests
|
||||
; declared_notifications
|
||||
; implemented_requests
|
||||
; implemented_notifications
|
||||
}
|
||||
;;
|
||||
|
||||
let register_generic
|
||||
t
|
||||
~method_
|
||||
~generations
|
||||
~registry
|
||||
~registry_key
|
||||
~other
|
||||
~other_key
|
||||
~pack
|
||||
=
|
||||
let () =
|
||||
get t other other_key
|
||||
|> Option.iter ~f:(fun _ ->
|
||||
Code_error.raise
|
||||
"attempted to implement and declare method"
|
||||
[ "method", Dyn.String method_ ])
|
||||
in
|
||||
let prior_registered_generations =
|
||||
get t registry registry_key |> Option.value ~default:Method.Version.Map.empty
|
||||
in
|
||||
let all_generations, duplicate_generations =
|
||||
List.fold_left
|
||||
generations
|
||||
~init:(prior_registered_generations, Method.Version.Set.empty)
|
||||
~f:(fun (acc, dups) (n, gen) ->
|
||||
match Method.Version.Map.add acc n (pack gen) with
|
||||
| Error _ -> acc, Method.Version.Set.add dups n
|
||||
| Ok acc' -> acc', dups)
|
||||
in
|
||||
if Method.Version.Set.is_empty duplicate_generations
|
||||
then set t registry registry_key all_generations
|
||||
else
|
||||
Code_error.raise
|
||||
"attempted to register duplicate generations for RPC method"
|
||||
[ "method", Dyn.String method_
|
||||
; "duplicated", Method.Version.Set.to_dyn duplicate_generations
|
||||
]
|
||||
;;
|
||||
|
||||
let declare_request t proc =
|
||||
register_generic
|
||||
t
|
||||
~method_:proc.Request.decl.method_
|
||||
~generations:proc.Request.generations
|
||||
~registry:Declared_requests
|
||||
~other:Impl_requests
|
||||
~registry_key:(proc.Request.decl.method_, proc.decl.key)
|
||||
~other_key:proc.Request.decl.method_
|
||||
~pack:Fun.id
|
||||
;;
|
||||
|
||||
let declare_notification t (proc : _ notification) =
|
||||
register_generic
|
||||
t
|
||||
~method_:proc.decl.method_
|
||||
~generations:proc.generations
|
||||
~registry:Declared_notifs
|
||||
~other:Impl_notifs
|
||||
~registry_key:(proc.decl.method_, proc.decl.key)
|
||||
~other_key:proc.decl.method_
|
||||
~pack:Fun.id
|
||||
;;
|
||||
|
||||
let implement_request t (proc : _ request) f =
|
||||
register_generic
|
||||
t
|
||||
~method_:proc.decl.method_
|
||||
~generations:proc.generations
|
||||
~registry:Impl_requests
|
||||
~other:Declared_requests
|
||||
~registry_key:proc.decl.method_
|
||||
~other_key:(proc.decl.method_, proc.decl.key)
|
||||
~pack:(fun r -> R (f, r))
|
||||
;;
|
||||
|
||||
let implement_notification t (proc : _ notification) f =
|
||||
register_generic
|
||||
t
|
||||
~method_:proc.decl.method_
|
||||
~generations:proc.generations
|
||||
~registry:Impl_notifs
|
||||
~other:Declared_notifs
|
||||
~registry_key:proc.decl.method_
|
||||
~other_key:(proc.decl.method_, proc.decl.key)
|
||||
~pack:(fun n -> N (f, n))
|
||||
;;
|
||||
|
||||
let lookup_method_generic t ~menu ~table ~key ~method_ k s =
|
||||
match get t table key, Menu.find menu method_ with
|
||||
| Some subtable, Some version -> s (subtable, version)
|
||||
| None, _ ->
|
||||
let payload = Sexp.record [ "method", Atom method_ ] in
|
||||
k (Version_error.create ~message:"invalid method" ~payload ())
|
||||
| _, None ->
|
||||
let payload = Sexp.record [ "method", Atom method_ ] in
|
||||
k
|
||||
(Version_error.create
|
||||
~message:"remote and local have no common version for method"
|
||||
~payload
|
||||
())
|
||||
;;
|
||||
|
||||
let to_handler t ~session_version =
|
||||
let open Fiber.O in
|
||||
let handle_request menu state (_id, (n : Call.t)) =
|
||||
lookup_method_generic
|
||||
t
|
||||
~menu
|
||||
~table:Impl_requests
|
||||
~key:n.method_
|
||||
~method_:n.method_
|
||||
(fun e -> Fiber.return (Error (Version_error.to_response_error e)))
|
||||
(fun (handlers, version) ->
|
||||
match Method.Version.Map.find handlers version with
|
||||
| None ->
|
||||
raise_version_bug
|
||||
~method_:n.method_
|
||||
~selected:version
|
||||
~verb:"unimplemented"
|
||||
~known:(Method.Version.Map.keys handlers)
|
||||
| Some (R (f, T gen)) ->
|
||||
(match Conv.of_sexp gen.req ~version:(session_version state) n.params with
|
||||
| Error e -> Fiber.return (Error (Response.Error.of_conv e))
|
||||
| Ok req ->
|
||||
let+ resp = f state (gen.upgrade_req req) in
|
||||
Ok (Conv.to_sexp gen.resp (gen.downgrade_resp resp))))
|
||||
in
|
||||
let handle_notification menu state (n : Call.t) =
|
||||
lookup_method_generic
|
||||
t
|
||||
~menu
|
||||
~table:Impl_notifs
|
||||
~key:n.method_
|
||||
~method_:n.method_
|
||||
(fun e -> Fiber.return (Error (Version_error.to_response_error e)))
|
||||
(fun (handlers, version) ->
|
||||
match Method.Version.Map.find handlers version with
|
||||
| None ->
|
||||
raise_version_bug
|
||||
~method_:n.method_
|
||||
~selected:version
|
||||
~verb:"unimplemented"
|
||||
~known:(Method.Version.Map.keys handlers)
|
||||
| Some (N (f, T gen)) ->
|
||||
(match Conv.of_sexp gen.req ~version:(session_version state) n.params with
|
||||
| Error e -> Fiber.return (Error (Response.Error.of_conv e))
|
||||
| Ok req ->
|
||||
let+ () = f state (gen.upgrade_req req) in
|
||||
Ok ()))
|
||||
in
|
||||
let prepare_request (type a b) menu (decl : (a, b) Decl.Request.witness)
|
||||
: ((a, b) Staged.request, Version_error.t) result
|
||||
=
|
||||
let method_ = decl.method_ in
|
||||
lookup_method_generic
|
||||
t
|
||||
~menu
|
||||
~table:Declared_requests
|
||||
~key:(method_, decl.key)
|
||||
~method_
|
||||
(fun e -> Error e)
|
||||
(fun (decls, version) ->
|
||||
match Method.Version.Map.find decls version with
|
||||
| None ->
|
||||
raise_version_bug
|
||||
~method_
|
||||
~selected:version
|
||||
~verb:"undeclared"
|
||||
~known:(Method.Version.Map.keys decls)
|
||||
| Some (T gen) ->
|
||||
let encode_req (req : a) =
|
||||
{ Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) }
|
||||
in
|
||||
let decode_resp sexp =
|
||||
match Conv.of_sexp gen.resp ~version:(3, 0) sexp with
|
||||
| Ok resp -> Ok (gen.upgrade_resp resp)
|
||||
| Error e -> Error (Response.Error.of_conv e)
|
||||
in
|
||||
Ok { Staged.encode_req; decode_resp })
|
||||
in
|
||||
let prepare_notification (type a) menu (decl : a Decl.Notification.witness)
|
||||
: (a Staged.notification, Version_error.t) result
|
||||
=
|
||||
let method_ = decl.method_ in
|
||||
lookup_method_generic
|
||||
t
|
||||
~menu
|
||||
~table:Declared_notifs
|
||||
~key:(method_, decl.key)
|
||||
~method_
|
||||
(fun e -> Error e)
|
||||
(fun (decls, version) ->
|
||||
match Method.Version.Map.find decls version with
|
||||
| None ->
|
||||
raise_version_bug
|
||||
~method_
|
||||
~selected:version
|
||||
~verb:"undeclared"
|
||||
~known:(Method.Version.Map.keys decls)
|
||||
| Some (T gen) ->
|
||||
let encode (req : a) =
|
||||
{ Call.method_; params = Conv.to_sexp gen.req (gen.downgrade_req req) }
|
||||
in
|
||||
Ok { Staged.encode })
|
||||
in
|
||||
fun ~menu ->
|
||||
{ Handler.menu
|
||||
; handle_request
|
||||
; handle_notification
|
||||
; prepare_request
|
||||
; prepare_notification
|
||||
}
|
||||
;;
|
||||
end
|
||||
end
|
||||
|
|
@ -0,0 +1,93 @@
|
|||
(** The main logic for the runtime versioning protocol for the Dune RPC. For a
|
||||
high-level explanation and rationale, see [doc/dev/rpc-versioning.ml]. *)
|
||||
|
||||
open Types
|
||||
|
||||
module Version_error : sig
|
||||
type t
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
val to_dyn : t -> Dyn.t
|
||||
|
||||
exception E of t
|
||||
end
|
||||
|
||||
module Staged : sig
|
||||
type ('req, 'resp) request =
|
||||
{ encode_req : 'req -> Call.t
|
||||
; decode_resp : Csexp.t -> ('resp, Response.Error.t) result
|
||||
}
|
||||
|
||||
type 'payload notification = { encode : 'payload -> Call.t }
|
||||
end
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
module Handler : sig
|
||||
type 'state t
|
||||
|
||||
val handle_request : 'state t -> 'state -> Request.t -> Response.t fiber
|
||||
|
||||
val handle_notification
|
||||
: 'state t
|
||||
-> 'state
|
||||
-> Call.t
|
||||
-> (unit, Response.Error.t) result fiber
|
||||
|
||||
val prepare_request
|
||||
: 'a t
|
||||
-> ('req, 'resp) Decl.Request.witness
|
||||
-> (('req, 'resp) Staged.request, Version_error.t) result
|
||||
|
||||
val prepare_notification
|
||||
: 'a t
|
||||
-> 'payload Decl.Notification.witness
|
||||
-> ('payload Staged.notification, Version_error.t) result
|
||||
end
|
||||
|
||||
module Builder : sig
|
||||
type 'state t
|
||||
|
||||
val to_handler
|
||||
: 'state t
|
||||
-> session_version:('state -> Version.t)
|
||||
-> menu:Menu.t
|
||||
-> 'state Handler.t
|
||||
|
||||
val create : unit -> 'state t
|
||||
val registered_procedures : 'a t -> (Method.Name.t * Method.Version.t list) list
|
||||
|
||||
(** A *declaration* of a procedure is a claim that this side of the session
|
||||
is able to *initiate* that procedure. Correspondingly, *implementing* a
|
||||
procedure enables you to *receive* that procedure (and probably do
|
||||
something in response).
|
||||
|
||||
Currently, attempting to both implement and declare the same procedure
|
||||
in the same builder will raise. While there is nothing fundamentally
|
||||
wrong with allowing this, it is simpler for the initial version
|
||||
negotiation to treat all method names uniformly, rather than specifying
|
||||
whether a given (set of) generation(s) is implemented or declared.
|
||||
|
||||
Finally, attempting to declare or implement the same generation twice
|
||||
will also raise. *)
|
||||
val declare_notification : 'state t -> 'payload Decl.notification -> unit
|
||||
|
||||
val declare_request : 'state t -> ('req, 'resp) Decl.request -> unit
|
||||
|
||||
val implement_notification
|
||||
: 'state t
|
||||
-> 'payload Decl.notification
|
||||
-> ('state -> 'payload -> unit fiber)
|
||||
-> unit
|
||||
|
||||
val implement_request
|
||||
: 'state t
|
||||
-> ('req, 'resp) Decl.request
|
||||
-> ('state -> 'req -> 'resp fiber)
|
||||
-> unit
|
||||
end
|
||||
end
|
||||
|
||||
module Make (Fiber : Fiber_intf.S) : S with type 'a fiber := 'a Fiber.t
|
||||
170
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/where.ml
Normal file
170
unikernel/duniverse/dune_/otherlibs/dune-rpc/private/where.ml
Normal file
|
|
@ -0,0 +1,170 @@
|
|||
open Import
|
||||
|
||||
type t =
|
||||
[ `Unix of string
|
||||
| `Ip of [ `Host of string ] * [ `Port of int ]
|
||||
]
|
||||
|
||||
let default_port = 8587
|
||||
let compare = Poly.compare
|
||||
|
||||
let ( let* ) x f =
|
||||
match x with
|
||||
| Ok s -> f s
|
||||
| Error _ as e -> e
|
||||
;;
|
||||
|
||||
type error = Invalid_where of string
|
||||
|
||||
exception E of error
|
||||
|
||||
let () =
|
||||
Printexc.register_printer (function
|
||||
| E (Invalid_where w) -> Some (Printf.sprintf "Invalid RPC address: %s" w)
|
||||
| _ -> None)
|
||||
;;
|
||||
|
||||
let of_dbus { Dbus_address.name; args } =
|
||||
match name with
|
||||
| "unix" ->
|
||||
(match List.assoc args "path" with
|
||||
| None -> Error "missing path field"
|
||||
| Some path -> Ok (`Unix path))
|
||||
| "tcp" ->
|
||||
let* port =
|
||||
match List.assoc args "port" with
|
||||
| None -> Ok default_port
|
||||
| Some p ->
|
||||
(match int_of_string p with
|
||||
| exception Failure _ -> Error "invalid port"
|
||||
| s -> Ok s)
|
||||
in
|
||||
let* addr =
|
||||
match List.assoc args "host" with
|
||||
| None -> Error "missing host field"
|
||||
| Some host -> Ok host
|
||||
in
|
||||
Ok (`Ip (`Host addr, `Port port))
|
||||
| _ -> Error "invalid connection type"
|
||||
;;
|
||||
|
||||
let of_string s : (t, exn) result =
|
||||
match Dbus_address.of_string s with
|
||||
| Error _ -> Error (E (Invalid_where ("invalid address format " ^ s)))
|
||||
| Ok s ->
|
||||
(match of_dbus s with
|
||||
| Ok s -> Ok s
|
||||
| Error e -> Error (E (Invalid_where e)))
|
||||
;;
|
||||
|
||||
let rpc_socket_relative_to_build_dir = ".rpc/dune"
|
||||
let env_var = "DUNE_RPC"
|
||||
|
||||
let to_dbus : t -> Dbus_address.t = function
|
||||
| `Unix p -> { name = "unix"; args = [ "path", p ] }
|
||||
| `Ip (`Host host, `Port port) ->
|
||||
let port = string_of_int port in
|
||||
{ name = "tcp"; args = [ "host", host; "port", port ] }
|
||||
;;
|
||||
|
||||
let to_dyn : t -> Dyn.t =
|
||||
let open Dyn in
|
||||
function
|
||||
| `Unix s -> variant "Unix" [ string s ]
|
||||
| `Ip (`Host host, `Port port) ->
|
||||
variant "Ip" [ variant "Host" [ string host ]; variant "Port" [ int port ] ]
|
||||
;;
|
||||
|
||||
let to_string t = Dbus_address.to_string (to_dbus t)
|
||||
|
||||
let sexp : t Conv.value =
|
||||
let open Conv in
|
||||
iso_result Conv.string of_string to_string
|
||||
;;
|
||||
|
||||
let add_to_env t env =
|
||||
let value = to_string t in
|
||||
Env.add env ~var:env_var ~value
|
||||
;;
|
||||
|
||||
let of_env env =
|
||||
match Env.get env env_var with
|
||||
| None -> Error `Missing
|
||||
| Some s ->
|
||||
(match of_string s with
|
||||
| Error exn -> Error (`Exn exn)
|
||||
| Ok s -> Ok s)
|
||||
;;
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
val get
|
||||
: env:(string -> string option)
|
||||
-> build_dir:string
|
||||
-> (t option, exn) result fiber
|
||||
|
||||
val default : ?win32:bool -> build_dir:string -> unit -> t
|
||||
end
|
||||
|
||||
let win32 = Sys.win32
|
||||
|
||||
module Make
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(IO : sig
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
|
||||
val analyze_path
|
||||
: string
|
||||
-> ([ `Unix_socket | `Normal_file | `Other ], exn) result Fiber.t
|
||||
end) : S with type 'a fiber := 'a Fiber.t = struct
|
||||
let default ?(win32 = win32) ~build_dir () =
|
||||
if win32
|
||||
then `Ip (`Host (Unix.string_of_inet_addr Unix.inet_addr_loopback), `Port default_port)
|
||||
else `Unix (Filename.concat build_dir rpc_socket_relative_to_build_dir)
|
||||
;;
|
||||
|
||||
let ( let** ) x f =
|
||||
let open Fiber.O in
|
||||
let* x = x in
|
||||
match x with
|
||||
| Error e -> Fiber.return (Error e)
|
||||
| Ok x -> f x
|
||||
;;
|
||||
|
||||
let get ~env ~build_dir : (t option, exn) result Fiber.t =
|
||||
let open Fiber.O in
|
||||
let* () = Fiber.return () in
|
||||
match env env_var with
|
||||
| Some d ->
|
||||
Fiber.return
|
||||
(match of_string d with
|
||||
| Ok s -> Ok (Some s)
|
||||
| Error exn -> Error exn)
|
||||
| None ->
|
||||
let of_file f =
|
||||
let+ contents = IO.read_file f in
|
||||
match contents with
|
||||
| Error e -> Error e
|
||||
| Ok contents ->
|
||||
(match of_string contents with
|
||||
| Error e -> Error e
|
||||
| Ok s -> Ok (Some s))
|
||||
in
|
||||
let file = Filename.concat build_dir rpc_socket_relative_to_build_dir in
|
||||
let** analyze = IO.analyze_path file in
|
||||
(match analyze with
|
||||
| `Other -> Fiber.return (Ok None)
|
||||
| `Normal_file -> of_file file
|
||||
| `Unix_socket -> Fiber.return (Ok (Some (`Unix file))))
|
||||
;;
|
||||
end
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
open Import
|
||||
|
||||
type t =
|
||||
[ `Unix of string
|
||||
| `Ip of [ `Host of string ] * [ `Port of int ]
|
||||
]
|
||||
|
||||
val rpc_socket_relative_to_build_dir : string
|
||||
val to_string : t -> string
|
||||
val compare : t -> t -> Ordering.t
|
||||
val to_dyn : t -> Dyn.t
|
||||
val sexp : t Conv.value
|
||||
val env_var : Env.Var.t
|
||||
val add_to_env : t -> Env.t -> Env.t
|
||||
val of_env : Env.t -> (t, [ `Exn of exn | `Missing ]) result
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
val get
|
||||
: env:(string -> string option)
|
||||
-> build_dir:string
|
||||
-> (t option, exn) result fiber
|
||||
|
||||
val default : ?win32:bool -> build_dir:string -> unit -> t
|
||||
end
|
||||
|
||||
type error = Invalid_where of string
|
||||
|
||||
exception E of error
|
||||
|
||||
module Make
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(_ : sig
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
|
||||
val analyze_path
|
||||
: string
|
||||
-> ([ `Unix_socket | `Normal_file | `Other ], exn) result Fiber.t
|
||||
end) : S with type 'a fiber := 'a Fiber.t
|
||||
96
unikernel/duniverse/dune_/otherlibs/dune-rpc/v1.ml
Normal file
96
unikernel/duniverse/dune_/otherlibs/dune-rpc/v1.ml
Normal file
|
|
@ -0,0 +1,96 @@
|
|||
open Dune_rpc_private
|
||||
module Id = Id
|
||||
module Response = Response
|
||||
module Version_error = Version_error
|
||||
module Initialize = Initialize.Request
|
||||
module Call = Call
|
||||
module Loc = Loc
|
||||
module Target = Target
|
||||
module Diagnostic = Diagnostic
|
||||
module Path = Path
|
||||
module Progress = Progress
|
||||
module Job = Job
|
||||
module Message = Message
|
||||
module Where = Where
|
||||
module Registry = Registry
|
||||
module Ansi_color = Ansi_color
|
||||
module User_message = User_message
|
||||
include Public
|
||||
|
||||
module Client = struct
|
||||
module type S = sig
|
||||
type t
|
||||
type 'a fiber
|
||||
type chan
|
||||
|
||||
module Handler : sig
|
||||
type t
|
||||
|
||||
val create
|
||||
: ?log:(Message.t -> unit fiber)
|
||||
-> ?abort:(Message.t -> unit fiber)
|
||||
-> unit
|
||||
-> t
|
||||
end
|
||||
|
||||
module Versioned : sig
|
||||
type 'a notification
|
||||
type ('a, 'b) request
|
||||
|
||||
val prepare_request
|
||||
: t
|
||||
-> ('a, 'b) Request.t
|
||||
-> (('a, 'b) request, Version_error.t) result fiber
|
||||
|
||||
val prepare_notification
|
||||
: t
|
||||
-> 'a Notification.t
|
||||
-> ('a notification, Version_error.t) result fiber
|
||||
end
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit fiber
|
||||
val disconnected : t -> unit fiber
|
||||
|
||||
module Stream : sig
|
||||
type 'a t
|
||||
|
||||
val cancel : _ t -> unit fiber
|
||||
val next : 'a t -> 'a option fiber
|
||||
end
|
||||
|
||||
val poll : ?id:Id.t -> t -> 'a Sub.t -> ('a Stream.t, Version_error.t) result fiber
|
||||
|
||||
module Batch : sig
|
||||
type client := t
|
||||
type t
|
||||
|
||||
val create : client -> t
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit
|
||||
val submit : t -> unit fiber
|
||||
end
|
||||
|
||||
val connect
|
||||
: ?handler:Handler.t
|
||||
-> chan
|
||||
-> Initialize.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
end
|
||||
|
||||
module Make = Client.Make
|
||||
end
|
||||
600
unikernel/duniverse/dune_/otherlibs/dune-rpc/v1.mli
Normal file
600
unikernel/duniverse/dune_/otherlibs/dune-rpc/v1.mli
Normal file
|
|
@ -0,0 +1,600 @@
|
|||
(** Implementation of the protocol used by dune rpc. Independent of IO and any
|
||||
specific rpc requests. The protocol described here is stable and is relied
|
||||
on by 3rd party clients.
|
||||
|
||||
The implementation is loosely modelled on jsonrpc. It defines the following
|
||||
concepts:
|
||||
|
||||
Session - An active rpc session
|
||||
|
||||
Request - A unique id with a call sent by a client. A server must respond to
|
||||
every request
|
||||
|
||||
Notification - A call send by a client. A server must not respond to a
|
||||
notification
|
||||
|
||||
It contains hooks that make it possible to use with any custom scheduler
|
||||
that uses fibers
|
||||
|
||||
The API in this version is versioned. When using this library, we expect
|
||||
that the module corresponding to a particular version is used exclusively.
|
||||
|
||||
While we guarantee stability of the API, we reserve the right to:
|
||||
|
||||
- Add optional arguments to functions
|
||||
- Add new fields to records
|
||||
- New variant constructors that will not cause runtime errors in existing
|
||||
user programs.
|
||||
|
||||
This means that you must refrain from re-exporting any values, constructing
|
||||
any records, using any module types as functor arguments, or make non
|
||||
exhaustive matches an error to guarantee compatibility. *)
|
||||
|
||||
[@@@alert unstable "The API of this library is not stable and may change without notice."]
|
||||
[@@@alert "-unstable"]
|
||||
|
||||
module Id : sig
|
||||
(** Id's for requests, responses, sessions.
|
||||
|
||||
Id's are permitted to be arbitrary s-expressions to allow users pick
|
||||
descriptive tokens to ease debugging. *)
|
||||
|
||||
type t
|
||||
|
||||
val make : Csexp.t -> t
|
||||
end
|
||||
|
||||
module Response : sig
|
||||
module Error : sig
|
||||
type kind =
|
||||
| Invalid_request
|
||||
| Code_error
|
||||
| Connection_dead
|
||||
|
||||
type t
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
val kind : t -> kind
|
||||
|
||||
exception E of t
|
||||
end
|
||||
|
||||
type t = (Csexp.t, Error.t) result
|
||||
end
|
||||
|
||||
module Initialize : sig
|
||||
type t
|
||||
|
||||
val create : id:Id.t -> t
|
||||
end
|
||||
|
||||
module Loc : sig
|
||||
type t
|
||||
|
||||
val start : t -> Lexing.position
|
||||
val stop : t -> Lexing.position
|
||||
end
|
||||
|
||||
module Path : sig
|
||||
type t
|
||||
|
||||
val dune_root : t
|
||||
val absolute : string -> t
|
||||
val relative : t -> string -> t
|
||||
val to_string_absolute : t -> string
|
||||
end
|
||||
|
||||
module Ansi_color : sig
|
||||
module RGB8 : sig
|
||||
(** 8-bit RGB color *)
|
||||
type t
|
||||
|
||||
(** [to_int t] returns the 8-bit color as an integer in the range [0, 255]. *)
|
||||
val to_int : t -> int
|
||||
end
|
||||
|
||||
module RGB24 : sig
|
||||
(** 24-bit RGB color (true color) *)
|
||||
type t
|
||||
|
||||
(** [red t] returns the red component of the 24-bit color [t]. *)
|
||||
val red : t -> int
|
||||
|
||||
(** [green t] returns the green component of the 24-bit color [t]. *)
|
||||
val green : t -> int
|
||||
|
||||
(** [blue t] returns the blue component of the 24-bit color [t]. *)
|
||||
val blue : t -> int
|
||||
|
||||
(** [to_int t] returns the 24-bit color as an integer in the range [0, 0xFFFFFF].
|
||||
Each color components consists of 8 bits. *)
|
||||
val to_int : t -> int
|
||||
end
|
||||
|
||||
module Style : sig
|
||||
(** Ansi Terminal Styles *)
|
||||
type t =
|
||||
[ `Fg_default
|
||||
| `Fg_black
|
||||
| `Fg_red
|
||||
| `Fg_green
|
||||
| `Fg_yellow
|
||||
| `Fg_blue
|
||||
| `Fg_magenta
|
||||
| `Fg_cyan
|
||||
| `Fg_white
|
||||
| `Fg_bright_black
|
||||
| `Fg_bright_red
|
||||
| `Fg_bright_green
|
||||
| `Fg_bright_yellow
|
||||
| `Fg_bright_blue
|
||||
| `Fg_bright_magenta
|
||||
| `Fg_bright_cyan
|
||||
| `Fg_bright_white
|
||||
| `Fg_8_bit_color of RGB8.t
|
||||
| `Fg_24_bit_color of RGB24.t
|
||||
| `Bg_default
|
||||
| `Bg_black
|
||||
| `Bg_red
|
||||
| `Bg_green
|
||||
| `Bg_yellow
|
||||
| `Bg_blue
|
||||
| `Bg_magenta
|
||||
| `Bg_cyan
|
||||
| `Bg_white
|
||||
| `Bg_bright_black
|
||||
| `Bg_bright_red
|
||||
| `Bg_bright_green
|
||||
| `Bg_bright_yellow
|
||||
| `Bg_bright_blue
|
||||
| `Bg_bright_magenta
|
||||
| `Bg_bright_cyan
|
||||
| `Bg_bright_white
|
||||
| `Bg_8_bit_color of RGB8.t
|
||||
| `Bg_24_bit_color of RGB24.t
|
||||
| `Bold
|
||||
| `Dim
|
||||
| `Italic
|
||||
| `Underline
|
||||
]
|
||||
end
|
||||
end
|
||||
|
||||
module User_message : sig
|
||||
(** User Message Styles *)
|
||||
module Style : sig
|
||||
type t =
|
||||
| Loc
|
||||
| Error
|
||||
| Warning
|
||||
| Kwd
|
||||
| Id
|
||||
| Prompt
|
||||
| Hint
|
||||
| Details
|
||||
| Ok
|
||||
| Debug
|
||||
| Success
|
||||
| Ansi_styles of Ansi_color.Style.t list
|
||||
end
|
||||
end
|
||||
|
||||
module Target : sig
|
||||
type t =
|
||||
| Path of string
|
||||
| Alias of string
|
||||
| Library of string
|
||||
| Executables of string list
|
||||
| Preprocess of string list
|
||||
| Loc of Loc.t
|
||||
end
|
||||
|
||||
module Diagnostic : sig
|
||||
type severity =
|
||||
| Error
|
||||
| Warning
|
||||
|
||||
module Promotion : sig
|
||||
type t
|
||||
|
||||
val in_build : t -> string
|
||||
val in_source : t -> string
|
||||
end
|
||||
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> Ordering.t
|
||||
val hash : t -> int
|
||||
val create : int -> t
|
||||
end
|
||||
|
||||
module Related : sig
|
||||
type t
|
||||
|
||||
val loc : t -> Loc.t
|
||||
val message : t -> unit Pp.t
|
||||
val message_with_style : t -> User_message.Style.t Pp.t
|
||||
end
|
||||
|
||||
type t
|
||||
|
||||
val related : t -> Related.t list
|
||||
val loc : t -> Loc.t option
|
||||
val id : t -> Id.t
|
||||
val message : t -> unit Pp.t
|
||||
val message_with_style : t -> User_message.Style.t Pp.t
|
||||
val severity : t -> severity option
|
||||
val promotion : t -> Promotion.t list
|
||||
|
||||
(* The list of targets is ordered such that the first element is the
|
||||
immediate ("innermost") target being built when the error was
|
||||
encountered, which was required by the next element, and so on. *)
|
||||
val targets : t -> Target.t list
|
||||
|
||||
(* The directory from which the action producing the error was run. This is
|
||||
often, but not always, the directory of the first target in [targets].
|
||||
This path of this directory is absolute.
|
||||
|
||||
If this is [None], then the error does not have an associated error (for
|
||||
example, if your opam installation is too old). *)
|
||||
val directory : t -> string option
|
||||
|
||||
module Event : sig
|
||||
type nonrec t =
|
||||
| Add of t
|
||||
| Remove of t
|
||||
end
|
||||
end
|
||||
|
||||
module Progress : sig
|
||||
type t =
|
||||
| Waiting
|
||||
| In_progress of
|
||||
{ complete : int
|
||||
; remaining : int
|
||||
; failed : int
|
||||
}
|
||||
| Failed
|
||||
| Interrupted
|
||||
| Success
|
||||
end
|
||||
|
||||
module Job : sig
|
||||
module Id : sig
|
||||
type t
|
||||
|
||||
val compare : t -> t -> Ordering.t
|
||||
val hash : t -> int
|
||||
end
|
||||
|
||||
type t
|
||||
|
||||
val id : t -> Id.t
|
||||
val description : t -> unit Pp.t
|
||||
val started_at : t -> float
|
||||
|
||||
module Event : sig
|
||||
type nonrec t =
|
||||
| Start of t
|
||||
| Stop of Id.t
|
||||
end
|
||||
end
|
||||
|
||||
module Sub : sig
|
||||
type 'a t
|
||||
|
||||
val progress : Progress.t t
|
||||
val diagnostic : Diagnostic.Event.t list t
|
||||
end
|
||||
|
||||
module Message : sig
|
||||
type t
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
end
|
||||
|
||||
(** A [Version_error] is returned on the client-side when a request or
|
||||
notification is determined to be invalid due to version negotiation (no
|
||||
known method or no common version). *)
|
||||
module Version_error : sig
|
||||
type t
|
||||
|
||||
val payload : t -> Csexp.t option
|
||||
val message : t -> string
|
||||
|
||||
exception E of t
|
||||
end
|
||||
|
||||
module Notification : sig
|
||||
type 'a t
|
||||
|
||||
(** Request dune to shutdown. The current build job will be cancelled. *)
|
||||
val shutdown : unit t
|
||||
end
|
||||
|
||||
module Request : sig
|
||||
type ('a, 'b) t
|
||||
|
||||
val ping : (unit, unit) t
|
||||
val diagnostics : (unit, Diagnostic.t list) t
|
||||
|
||||
(** format a [dune], [dune-project], or a [dune-workspace] file. The full
|
||||
path to the file is necessary so that dune knows the formatting options
|
||||
for the project this file is in *)
|
||||
val format_dune_file : (Path.t * [ `Contents of string ], string) t
|
||||
|
||||
(** Promote a file. *)
|
||||
val promote : (Path.t, unit) t
|
||||
|
||||
(** Returns the location of the build directory for the current build. *)
|
||||
val build_dir : (unit, Path.t) t
|
||||
end
|
||||
|
||||
module Client : sig
|
||||
module type S = sig
|
||||
(** Rpc client *)
|
||||
|
||||
type t
|
||||
type 'a fiber
|
||||
type chan
|
||||
|
||||
module Handler : sig
|
||||
type t
|
||||
|
||||
val create
|
||||
: ?log:(Message.t -> unit fiber)
|
||||
-> ?abort:(Message.t -> unit fiber)
|
||||
(** If [abort] is called, the server has terminated the
|
||||
connection due to a protocol error. This should never be
|
||||
called unless there's a server side bug. *)
|
||||
-> unit
|
||||
-> t
|
||||
end
|
||||
|
||||
(** Individual RPC procedures are versioned beyond the larger API version.
|
||||
At session startup, the server and client exchange version information
|
||||
for each method ("negotiation"), setting on a common version for each
|
||||
(if possible) to produce a "version menu".
|
||||
|
||||
To initiate a method, then, that method must be looked up in the
|
||||
version menu to determine the correct protocol for this session. This
|
||||
module stages this pattern to share the lookup for all calls to the
|
||||
same procedure.
|
||||
|
||||
For lower-level design details, see [doc/dev/rpc-versioning.md] in the
|
||||
main dune repository. *)
|
||||
module Versioned : sig
|
||||
type 'a notification
|
||||
type ('a, 'b) request
|
||||
|
||||
(** [prepare_request client r] checks the request [r] against the
|
||||
negotiated version menu, giving a versioned request as a result.
|
||||
|
||||
This function does not initiate any communication with the server.
|
||||
However, as this function must check the version menu, it cannot
|
||||
complete until after version negotiation, and so returns a [fiber]. *)
|
||||
val prepare_request
|
||||
: t
|
||||
-> ('a, 'b) Request.t
|
||||
-> (('a, 'b) request, Version_error.t) result fiber
|
||||
|
||||
(** See [prepare_request]. *)
|
||||
val prepare_notification
|
||||
: t
|
||||
-> 'a Notification.t
|
||||
-> ('a notification, Version_error.t) result fiber
|
||||
end
|
||||
|
||||
(** [request ?id client decl req] send a request [req] specified by [decl]
|
||||
to [client]. If [id] is [None], it will be automatically generated. *)
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit fiber
|
||||
|
||||
(** [disconnected client] produces a fiber that only becomes determined
|
||||
when the session is ended from the server side (such as if the build
|
||||
server is killed entirely). *)
|
||||
val disconnected : t -> unit fiber
|
||||
|
||||
module Stream : sig
|
||||
(** Control for a polling loop *)
|
||||
|
||||
type 'a t
|
||||
|
||||
(** [cancel t] notify the server that we are stopping our polling loop.
|
||||
It is an error to call [next] after [cancel] *)
|
||||
val cancel : _ t -> unit fiber
|
||||
|
||||
(** [next t] poll for the next value. It is an error to call [next]
|
||||
again until the previous [next] terminated. If [next] returns
|
||||
[None], subsequent calls to [next] is forbidden. *)
|
||||
val next : 'a t -> 'a option fiber
|
||||
end
|
||||
|
||||
(** [poll client sub] Initialize a polling loop for [sub] *)
|
||||
val poll : ?id:Id.t -> t -> 'a Sub.t -> ('a Stream.t, Version_error.t) result fiber
|
||||
|
||||
module Batch : sig
|
||||
type client := t
|
||||
type t
|
||||
|
||||
val create : client -> t
|
||||
|
||||
val request
|
||||
: ?id:Id.t
|
||||
-> t
|
||||
-> ('a, 'b) Versioned.request
|
||||
-> 'a
|
||||
-> ('b, Response.Error.t) result fiber
|
||||
|
||||
val notification : t -> 'a Versioned.notification -> 'a -> unit
|
||||
val submit : t -> unit fiber
|
||||
end
|
||||
|
||||
(** [connect ?on_handler session init ~f] connect to [session], initialize
|
||||
with [init] and call [f] once the client is initialized. [handler] is
|
||||
called for some notifications sent to [session] *)
|
||||
val connect
|
||||
: ?handler:Handler.t
|
||||
-> chan
|
||||
-> Initialize.t
|
||||
-> f:(t -> 'a fiber)
|
||||
-> 'a fiber
|
||||
end
|
||||
|
||||
(** Functor to create a client implementation *)
|
||||
module Make
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val fork_and_join_unit : (unit -> unit t) -> (unit -> 'a t) -> 'a t
|
||||
val parallel_iter : (unit -> 'a option t) -> f:('a -> unit t) -> unit t
|
||||
val finalize : (unit -> 'a t) -> finally:(unit -> unit t) -> 'a t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
|
||||
module Ivar : sig
|
||||
type 'a fiber := 'a t
|
||||
type 'a t
|
||||
|
||||
val create : unit -> 'a t
|
||||
val read : 'a t -> 'a fiber
|
||||
val fill : 'a t -> 'a -> unit fiber
|
||||
end
|
||||
end)
|
||||
(Chan : sig
|
||||
type t
|
||||
|
||||
(* [write t x] writes the s-expression when [x] is [Some _], and closes
|
||||
the session if [x = None] *)
|
||||
val write : t -> Csexp.t list option -> unit Fiber.t
|
||||
|
||||
(* [read t] attempts to read from [t]. If an s-expression is read, it is
|
||||
returned as [Some sexp], otherwise [None] is returned and the session
|
||||
is closed. *)
|
||||
val read : t -> Csexp.t option Fiber.t
|
||||
end) : S with type 'a fiber := 'a Fiber.t and type chan := Chan.t
|
||||
end
|
||||
|
||||
module Where : sig
|
||||
(** represents the address where a dune rpc instance might be listening *)
|
||||
|
||||
type t =
|
||||
[ `Unix of string
|
||||
| `Ip of [ `Host of string ] * [ `Port of int ]
|
||||
]
|
||||
|
||||
type error = Invalid_where of string
|
||||
|
||||
exception E of error
|
||||
|
||||
module type S = sig
|
||||
type 'a fiber
|
||||
|
||||
val get
|
||||
: env:(string -> string option)
|
||||
-> build_dir:string
|
||||
-> (t option, exn) result fiber
|
||||
|
||||
val default : ?win32:bool -> build_dir:string -> unit -> t
|
||||
end
|
||||
|
||||
(** obtain the address from the build directory and environment *)
|
||||
module Make
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(_ : sig
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
|
||||
val analyze_path
|
||||
: string
|
||||
-> ([ `Unix_socket | `Normal_file | `Other ], exn) result Fiber.t
|
||||
end) : S with type 'a fiber := 'a Fiber.t
|
||||
end
|
||||
|
||||
module Registry : sig
|
||||
(** The registry is where all running instances of dune rpc are stored.
|
||||
|
||||
It's used by clients to determine which dune rpc instance corresponds to
|
||||
the workspace they're trying to edit. *)
|
||||
|
||||
module Dune : sig
|
||||
(** a registered instance of dune. supposedly running and listening to rpc
|
||||
connections *)
|
||||
|
||||
type t
|
||||
|
||||
val to_dyn : t -> Dyn.t
|
||||
val compare : t -> t -> Ordering.t
|
||||
val pid : t -> int
|
||||
val where : t -> Where.t
|
||||
val root : t -> string
|
||||
end
|
||||
|
||||
module Config : sig
|
||||
(** The registry directory is located using xdg *)
|
||||
|
||||
type t
|
||||
|
||||
val create : Xdg.t -> t
|
||||
val watch_dir : t -> string
|
||||
end
|
||||
|
||||
type t
|
||||
|
||||
val create : Config.t -> t
|
||||
|
||||
(** currently detected running instances *)
|
||||
val current : t -> Dune.t list
|
||||
|
||||
module Refresh : sig
|
||||
(** the result of polling the registry *)
|
||||
|
||||
type t
|
||||
|
||||
val added : t -> Dune.t list
|
||||
val removed : t -> Dune.t list
|
||||
val errored : t -> (string * exn) list
|
||||
end
|
||||
|
||||
(** we can poll the registry efficiently using the following functor *)
|
||||
module Poll
|
||||
(Fiber : sig
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val parallel_map : 'a list -> f:('a -> 'b t) -> 'b list t
|
||||
|
||||
module O : sig
|
||||
val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
|
||||
end
|
||||
end)
|
||||
(_ : sig
|
||||
val scandir : string -> (string list, exn) result Fiber.t
|
||||
val stat : string -> ([ `Mtime of float ], exn) result Fiber.t
|
||||
val read_file : string -> (string, exn) result Fiber.t
|
||||
end) : sig
|
||||
val poll : t -> (Refresh.t, exn) result Fiber.t
|
||||
end
|
||||
end
|
||||
Loading…
Add table
Add a link
Reference in a new issue