Properly restrict SPKI SEXP display hints to octet strings
This commit is contained in:
parent
a1c88f74bb
commit
1836cc51e9
|
@ -214,11 +214,11 @@ let make_queue_declare_ok info =
|
||||||
|
|
||||||
let send_delivery conn consumer_tag body_sexp =
|
let send_delivery conn consumer_tag body_sexp =
|
||||||
match body_sexp with
|
match body_sexp with
|
||||||
| Sexp.Hint {Sexp.hint = Sexp.Str "amqp";
|
| Sexp.Arr [Sexp.Hint {Sexp.hint = "amqp"; Sexp.body = ""};
|
||||||
Sexp.body = Sexp.Arr [Sexp.Str exchange;
|
Sexp.Str exchange;
|
||||||
Sexp.Str routing_key;
|
Sexp.Str routing_key;
|
||||||
properties_sexp;
|
properties_sexp;
|
||||||
Sexp.Str body_str]} ->
|
Sexp.Str body_str] ->
|
||||||
lwt tag = with_conn_mutex conn (fun () ->
|
lwt tag = with_conn_mutex conn (fun () ->
|
||||||
let v = conn.delivery_tag in conn.delivery_tag <- v + 1; return v)
|
let v = conn.delivery_tag in conn.delivery_tag <- v + 1; return v)
|
||||||
in
|
in
|
||||||
|
@ -226,7 +226,7 @@ let send_delivery conn consumer_tag body_sexp =
|
||||||
(Basic_deliver (consumer_tag, Int64.of_int tag, false, exchange, routing_key))
|
(Basic_deliver (consumer_tag, Int64.of_int tag, false, exchange, routing_key))
|
||||||
(properties_of_sexp basic_class_id properties_sexp)
|
(properties_of_sexp basic_class_id properties_sexp)
|
||||||
body_str
|
body_str
|
||||||
| _ -> die internal_error "Malformed AMQP message body sexp"
|
| _ -> die internal_error "Malformed AMQP message body sexp"
|
||||||
|
|
||||||
let amqp_handler conn n m_sexp =
|
let amqp_handler conn n m_sexp =
|
||||||
try
|
try
|
||||||
|
@ -344,11 +344,11 @@ let handle_method conn channel m =
|
||||||
(match_lwt
|
(match_lwt
|
||||||
Node.post' sink
|
Node.post' sink
|
||||||
(Sexp.Str name)
|
(Sexp.Str name)
|
||||||
(Sexp.Hint {Sexp.hint = Sexp.Str "amqp";
|
(Sexp.Arr [Sexp.Hint {Sexp.hint = "amqp"; Sexp.body = ""};
|
||||||
Sexp.body = Sexp.Arr [Sexp.Str exchange;
|
Sexp.Str exchange;
|
||||||
Sexp.Str routing_key;
|
Sexp.Str routing_key;
|
||||||
sexp_of_properties properties;
|
sexp_of_properties properties;
|
||||||
Sexp.Str body]})
|
Sexp.Str body])
|
||||||
(Sexp.Str "")
|
(Sexp.Str "")
|
||||||
with
|
with
|
||||||
| true -> return ()
|
| true -> return ()
|
||||||
|
|
|
@ -231,11 +231,16 @@ let sexp_of_bit x = if x then Str "1" else Str ""
|
||||||
let sexp_of_timestamp x = Str (Int64.to_string x)
|
let sexp_of_timestamp x = Str (Int64.to_string x)
|
||||||
|
|
||||||
let rec
|
let rec
|
||||||
sexp_of_table x = Hint {hint = Str "table";
|
sexp_of_table x = Arr ((Hint {hint = "table"; body = ""}) ::
|
||||||
body = Arr (List.map sexp_of_named_field (decoded_table x))}
|
(List.map sexp_of_named_field (decoded_table x)))
|
||||||
and sexp_of_named_field (s, f) = Arr [Str s; sexp_of_unnamed_field f]
|
and sexp_of_named_field (s, f) =
|
||||||
|
let (t, v) = tag_val f in
|
||||||
|
Arr [Str s; t; v]
|
||||||
and sexp_of_unnamed_field f =
|
and sexp_of_unnamed_field f =
|
||||||
let h hs v = Hint {hint = Str hs; body = v} in
|
let (t, v) = tag_val f in
|
||||||
|
Arr [t; v]
|
||||||
|
and tag_val f =
|
||||||
|
let h hs v = (Str hs, v) in
|
||||||
match f with
|
match f with
|
||||||
| Table_bool true -> h "t" (Str "1")
|
| Table_bool true -> h "t" (Str "1")
|
||||||
| Table_bool false -> h "t" (Str "")
|
| Table_bool false -> h "t" (Str "")
|
||||||
|
@ -252,11 +257,11 @@ and sexp_of_unnamed_field f =
|
||||||
| Table_decimal (scale, v) -> h "D" (Arr [Arr [Str "scale"; sexp_of_octet scale];
|
| Table_decimal (scale, v) -> h "D" (Arr [Arr [Str "scale"; sexp_of_octet scale];
|
||||||
Arr [Str "value"; sexp_of_long v]])
|
Arr [Str "value"; sexp_of_long v]])
|
||||||
| Table_short_string v -> h "s" (Str v)
|
| Table_short_string v -> h "s" (Str v)
|
||||||
| Table_string v -> Str v
|
| Table_string v -> h "S" (Str v)
|
||||||
| Table_array vs -> h "A" (Arr (List.map sexp_of_unnamed_field vs))
|
| Table_array vs -> h "A" (Arr (List.map sexp_of_unnamed_field vs))
|
||||||
| Table_timestamp v -> h "T" (sexp_of_longlong v)
|
| Table_timestamp v -> h "T" (sexp_of_longlong v)
|
||||||
| Table_table t -> sexp_of_table t
|
| Table_table t -> h "F" (sexp_of_table t)
|
||||||
| Table_void -> Arr []
|
| Table_void -> h "V" (Arr [])
|
||||||
|
|
||||||
let table_of_list fs = { table_body = Decoded_table fs }
|
let table_of_list fs = { table_body = Decoded_table fs }
|
||||||
|
|
||||||
|
@ -281,42 +286,41 @@ let timestamp_of_sexp v = match v with Str x -> Int64.of_string x | _ -> reserve
|
||||||
|
|
||||||
let rec table_of_sexp v =
|
let rec table_of_sexp v =
|
||||||
match v with
|
match v with
|
||||||
| Hint {hint = Str "table"; body = Arr field_sexps} ->
|
| Arr ((Hint {hint = "table"; body = ""}) :: field_sexps) ->
|
||||||
table_of_list (List.map named_sexp_field field_sexps)
|
table_of_list (List.map named_sexp_field field_sexps)
|
||||||
| _ ->
|
| _ ->
|
||||||
table_of_list []
|
table_of_list []
|
||||||
and named_sexp_field v =
|
and named_sexp_field v =
|
||||||
match v with
|
match v with
|
||||||
| Arr [Str s; f] -> (s, field_of_sexp f)
|
| Arr [Str s; Str t; f] -> (s, untag_val (t, f))
|
||||||
| _ -> ("", Table_void)
|
| _ -> ("", Table_void)
|
||||||
and field_of_sexp v =
|
and field_of_sexp v =
|
||||||
match v with
|
match v with
|
||||||
| Hint {hint = Str "t"; body = Str x} ->
|
| Arr [Str t; f] -> untag_val (t, f)
|
||||||
Table_bool (x <> "")
|
| _ -> Table_void
|
||||||
| Hint {hint = Str "b"; body = v} ->
|
and untag_val (t, v) =
|
||||||
Table_signed_byte (unsigned_to_signed (octet_of_sexp v) 256)
|
match (t, v) with
|
||||||
| Hint {hint = Str "B"; body = v} ->
|
| ("t", Str x) -> Table_bool (x <> "")
|
||||||
Table_unsigned_byte (octet_of_sexp v)
|
| ("b", v) -> Table_signed_byte (unsigned_to_signed (octet_of_sexp v) 256)
|
||||||
| Hint {hint = Str "U"; body = v} ->
|
| ("B", v) -> Table_unsigned_byte (octet_of_sexp v)
|
||||||
Table_signed_short (unsigned_to_signed (short_of_sexp v) 65536)
|
| ("U", v) -> Table_signed_short (unsigned_to_signed (short_of_sexp v) 65536)
|
||||||
| Hint {hint = Str "u"; body = v} ->
|
| ("u", v) -> Table_unsigned_short (short_of_sexp v)
|
||||||
Table_unsigned_short (short_of_sexp v)
|
| ("I", v) -> Table_signed_long (long_of_sexp v)
|
||||||
| Hint {hint = Str "I"; body = v} -> Table_signed_long (long_of_sexp v)
|
| ("i", v) -> Table_unsigned_long (long_of_sexp v)
|
||||||
| Hint {hint = Str "i"; body = v} -> Table_unsigned_long (long_of_sexp v)
|
| ("L", v) -> Table_signed_longlong (longlong_of_sexp v)
|
||||||
| Hint {hint = Str "L"; body = v} -> Table_signed_longlong (longlong_of_sexp v)
|
| ("l", v) -> Table_unsigned_longlong (longlong_of_sexp v)
|
||||||
| Hint {hint = Str "l"; body = v} -> Table_unsigned_longlong (longlong_of_sexp v)
|
| ("f", Str v) -> Table_float v
|
||||||
| Hint {hint = Str "f"; body = (Str v)} -> Table_float v
|
| ("d", Str v) -> Table_double v
|
||||||
| Hint {hint = Str "d"; body = (Str v)} -> Table_double v
|
| ("D", Arr [Arr [Str "scale"; scale];
|
||||||
| Hint {hint = Str "D"; body = (Arr [Arr [Str "scale"; scale];
|
Arr [Str "value"; v]]) ->
|
||||||
Arr [Str "value"; v]])} ->
|
|
||||||
Table_decimal (octet_of_sexp scale, long_of_sexp v)
|
Table_decimal (octet_of_sexp scale, long_of_sexp v)
|
||||||
| Hint {hint = Str "s"; body = (Str v)} -> Table_short_string v
|
| ("s", Str v) -> Table_short_string v
|
||||||
| Str v -> Table_string v
|
| ("S", Str v) -> Table_string v
|
||||||
| Hint {hint = Str "A"; body = Arr vs} -> Table_array (List.map field_of_sexp vs)
|
| ("A", Arr vs) -> Table_array (List.map field_of_sexp vs)
|
||||||
| Hint {hint = Str "T"; body = v} -> Table_timestamp (longlong_of_sexp v)
|
| ("T", v) -> Table_timestamp (longlong_of_sexp v)
|
||||||
| Hint {hint = Str "table"; body = _} -> Table_table (table_of_sexp v)
|
| ("F", v) -> Table_table (table_of_sexp v)
|
||||||
| Arr [] -> Table_void
|
| ("V", Arr []) -> Table_void
|
||||||
| _ -> Table_void
|
| _ -> Table_void
|
||||||
|
|
||||||
let field_lookup k def fs =
|
let field_lookup k def fs =
|
||||||
try List.assoc k fs
|
try List.assoc k fs
|
||||||
|
|
|
@ -22,7 +22,7 @@ open Lwt_io
|
||||||
|
|
||||||
exception Syntax_error of string
|
exception Syntax_error of string
|
||||||
|
|
||||||
type display_hint_t = {hint : t; body : t}
|
type display_hint_t = {hint : string; body : string}
|
||||||
and t =
|
and t =
|
||||||
| Str of string
|
| Str of string
|
||||||
| Hint of display_hint_t
|
| Hint of display_hint_t
|
||||||
|
@ -46,18 +46,22 @@ let intstr =
|
||||||
loop (n / 10) (i + 1))
|
loop (n / 10) (i + 1))
|
||||||
in loop n 0
|
in loop n 0
|
||||||
|
|
||||||
|
let write_simple_string write s =
|
||||||
|
lwt () = write (intstr (String.length s)) in
|
||||||
|
lwt () = write ":" in
|
||||||
|
write s
|
||||||
|
|
||||||
let generic_output_sexp write x =
|
let generic_output_sexp write x =
|
||||||
|
let writestr = write_simple_string write in
|
||||||
let rec walk x =
|
let rec walk x =
|
||||||
match x with
|
match x with
|
||||||
| Str s ->
|
| Str s ->
|
||||||
lwt () = write (intstr (String.length s)) in
|
writestr s
|
||||||
lwt () = write ":" in
|
|
||||||
write s
|
|
||||||
| Hint {hint = h; body = b} ->
|
| Hint {hint = h; body = b} ->
|
||||||
lwt () = write "[" in
|
lwt () = write "[" in
|
||||||
lwt () = walk h in
|
lwt () = writestr h in
|
||||||
lwt () = write "]" in
|
lwt () = write "]" in
|
||||||
walk b
|
writestr b
|
||||||
| Arr xs ->
|
| Arr xs ->
|
||||||
lwt () = write "(" in
|
lwt () = write "(" in
|
||||||
lwt () = Lwt_list.iter_s walk xs in
|
lwt () = Lwt_list.iter_s walk xs in
|
||||||
|
@ -72,17 +76,20 @@ let write_char_escaped ch c =
|
||||||
then write ch "\\\""
|
then write ch "\\\""
|
||||||
else write_char ch c
|
else write_char ch c
|
||||||
|
|
||||||
|
let write_simple_string_human ch s =
|
||||||
|
lwt () = write_char ch '\"' in
|
||||||
|
lwt () = write ch (String.escaped s) in
|
||||||
|
write_char ch '\"'
|
||||||
|
|
||||||
let rec output_sexp_human ch x =
|
let rec output_sexp_human ch x =
|
||||||
match x with
|
match x with
|
||||||
| Str s ->
|
| Str s ->
|
||||||
lwt () = write_char ch '\"' in
|
write_simple_string_human ch s
|
||||||
lwt () = write ch (String.escaped s) in
|
|
||||||
write_char ch '\"'
|
|
||||||
| Hint {hint = h; body = b} ->
|
| Hint {hint = h; body = b} ->
|
||||||
lwt () = write_char ch '[' in
|
lwt () = write_char ch '[' in
|
||||||
lwt () = output_sexp_human ch h in
|
lwt () = write_simple_string_human ch h in
|
||||||
lwt () = write_char ch ']' in
|
lwt () = write_char ch ']' in
|
||||||
output_sexp_human ch b
|
write_simple_string_human ch b
|
||||||
| Arr xs ->
|
| Arr xs ->
|
||||||
lwt () = write_char ch '(' in
|
lwt () = write_char ch '(' in
|
||||||
lwt () =
|
lwt () =
|
||||||
|
@ -111,7 +118,7 @@ let syntax_error explanation = raise_lwt (Syntax_error explanation)
|
||||||
let input_sexp_outer input_char input_bytes =
|
let input_sexp_outer input_char input_bytes =
|
||||||
let rec input_simple_string len =
|
let rec input_simple_string len =
|
||||||
match_lwt input_char () with
|
match_lwt input_char () with
|
||||||
| ':' -> lwt bs = input_bytes len in return (Str bs)
|
| ':' -> lwt bs = input_bytes len in return bs
|
||||||
| b when char_numeric b -> input_simple_string (len * 10 + digit_val b)
|
| b when char_numeric b -> input_simple_string (len * 10 + digit_val b)
|
||||||
| _ -> syntax_error "Bad simple-string length character"
|
| _ -> syntax_error "Bad simple-string length character"
|
||||||
in
|
in
|
||||||
|
@ -131,7 +138,7 @@ let input_sexp_outer input_char input_bytes =
|
||||||
| ']' -> lwt b = input_simple_string 0 in return (Some (Hint {hint = hint; body = b}))
|
| ']' -> lwt b = input_simple_string 0 in return (Some (Hint {hint = hint; body = b}))
|
||||||
| _ -> syntax_error "Missing close-bracket in display hint")
|
| _ -> syntax_error "Missing close-bracket in display hint")
|
||||||
| b when char_numeric b ->
|
| b when char_numeric b ->
|
||||||
lwt s = input_simple_string (digit_val b) in return (Some s)
|
lwt s = input_simple_string (digit_val b) in return (Some (Str s))
|
||||||
| b when char_whitespace b ->
|
| b when char_whitespace b ->
|
||||||
(* Convenience for testing *)
|
(* Convenience for testing *)
|
||||||
input_sexp_inner ()
|
input_sexp_inner ()
|
||||||
|
|
|
@ -2,29 +2,29 @@ open Sexp
|
||||||
|
|
||||||
let rec sexp_of_json j =
|
let rec sexp_of_json j =
|
||||||
match j with
|
match j with
|
||||||
| Json.Num f -> Hint {hint = Str "num"; body = Str (Json.to_string j)}
|
| Json.Num f -> Hint {hint = "num"; body = Json.to_string j}
|
||||||
| Json.Str s -> Str s
|
| Json.Str s -> Str s
|
||||||
| Json.Arr js -> Arr (List.map sexp_of_json js)
|
| Json.Arr js -> Arr (List.map sexp_of_json js)
|
||||||
| Json.Rec kvs -> Hint {hint = Str "obj";
|
| Json.Rec kvs -> Arr ((Hint {hint = "obj"; body = ""}) ::
|
||||||
body = Arr (List.map (fun (k, v) -> Arr [Str k; sexp_of_json v]) kvs)}
|
(List.map (fun (k, v) -> Arr [Str k; sexp_of_json v]) kvs))
|
||||||
| Json.Flg f -> Hint {hint = Str "bool"; body = Str (string_of_bool f)}
|
| Json.Flg f -> Hint {hint = "bool"; body = string_of_bool f}
|
||||||
| Json.Nil -> Hint {hint = Str "null"; body = Arr []}
|
| Json.Nil -> Hint {hint = "null"; body = ""}
|
||||||
|
|
||||||
let json_of_sexp x =
|
let json_of_sexp x =
|
||||||
let rec walk x =
|
let rec walk x =
|
||||||
match x with
|
match x with
|
||||||
| Hint {hint = Str "num"; body = Str n} -> Json.Num (float_of_string n)
|
| Hint {hint = "num"; body = n} -> Json.Num (float_of_string n)
|
||||||
| Str s -> Json.Str s
|
| Str s -> Json.Str s
|
||||||
| Arr xs -> Json.Arr (List.map walk xs)
|
| Arr ((Hint {hint = "obj"; body = ""}) :: kvs) ->
|
||||||
| Hint {hint = Str "obj"; body = Arr kvs} ->
|
|
||||||
Json.Rec (List.map
|
Json.Rec (List.map
|
||||||
(fun kv ->
|
(fun kv ->
|
||||||
(match kv with
|
(match kv with
|
||||||
| Arr [Str k; v] -> (k, walk v)
|
| Arr [Str k; v] -> (k, walk v)
|
||||||
| _ -> raise (Syntax_error "Bad JSON-SEXP key-value")))
|
| _ -> raise (Syntax_error "Bad JSON-SEXP key-value")))
|
||||||
kvs)
|
kvs)
|
||||||
| Hint {hint = Str "bool"; body = Str bs} -> Json.Flg (bool_of_string bs)
|
| Arr xs -> Json.Arr (List.map walk xs)
|
||||||
| Hint {hint = Str "null"; body = Arr []} -> Json.Nil
|
| Hint {hint = "bool"; body = bs} -> Json.Flg (bool_of_string bs)
|
||||||
| Hint {hint = h; body = b} -> Json.Rec ["_hint", walk h; "_body", walk b]
|
| Hint {hint = "null"; body = ""} -> Json.Nil
|
||||||
|
| Hint {hint = h; body = b} -> Json.Rec ["_hint", Json.Str h; "_body", Json.Str b]
|
||||||
in
|
in
|
||||||
Lwt.wrap1 walk x
|
Lwt.wrap1 walk x
|
||||||
|
|
Loading…
Reference in New Issue