mirror of
https://github.com/c-cube/ocaml-containers.git
synced 2025-12-06 11:15:31 -05:00
feat: add RESP2 encoder/decoder
This commit is contained in:
Simon Cruanes
parent
522772356f
commit
deef13eb36
2 changed files with 207 additions and 0 deletions
202
src/resp2/containers_resp2.ml
Normal file
202
src/resp2/containers_resp2.ml
Normal file
|
|
@ -0,0 +1,202 @@
|
||||||
|
(** Main data type *)
|
||||||
|
module Data = struct
|
||||||
|
type t =
|
||||||
|
| Simple_string of string
|
||||||
|
| Bulk_string of string
|
||||||
|
| Int of int
|
||||||
|
| Error of string
|
||||||
|
| Array of t list
|
||||||
|
|
||||||
|
let rec pp out = function
|
||||||
|
| Simple_string s -> Format.fprintf out "%S" s
|
||||||
|
| Bulk_string s -> Format.fprintf out "bulk %S" s
|
||||||
|
| Int i -> Format.fprintf out "%d" i
|
||||||
|
| Error s -> Format.fprintf out "error %S" s
|
||||||
|
| Array l ->
|
||||||
|
Format.fprintf out "@[<v2>*%d@ " (List.length l);
|
||||||
|
List.iter (fun s -> Format.fprintf out "@[%a@]" pp s) l;
|
||||||
|
Format.fprintf out "@]"
|
||||||
|
|
||||||
|
let show d = Format.asprintf "%a" pp d
|
||||||
|
end
|
||||||
|
|
||||||
|
module Parse = struct
|
||||||
|
type 'a action =
|
||||||
|
| Return of 'a
|
||||||
|
| Fail of string
|
||||||
|
| Read_char of (char -> 'a action)
|
||||||
|
| Read_line of (string -> 'a action)
|
||||||
|
| Read_exact of int * (string -> 'a action)
|
||||||
|
| Bind : 'b action * ('b -> 'a action) -> 'a action
|
||||||
|
|
||||||
|
let[@inline] return x = Return x
|
||||||
|
let[@inline] fail str = Fail str
|
||||||
|
let[@inline] read_char f = Read_char f
|
||||||
|
let[@inline] read_exact i f = Read_exact (i, f)
|
||||||
|
let[@inline] read_line f = Read_line f
|
||||||
|
let[@inline] ( >>= ) x f = Bind (x, f)
|
||||||
|
|
||||||
|
let rec cont_parser () : Data.t action =
|
||||||
|
read_char @@ function
|
||||||
|
| '+' ->
|
||||||
|
read_line @@ fun line -> return (Data.Simple_string (String.trim line))
|
||||||
|
| '-' -> read_line @@ fun line -> return (Data.Error (String.trim line))
|
||||||
|
| ':' ->
|
||||||
|
read_line @@ fun line ->
|
||||||
|
(try return (Data.Int (int_of_string @@ String.trim line))
|
||||||
|
with _ -> fail "expected integer")
|
||||||
|
| '$' ->
|
||||||
|
read_line @@ fun line ->
|
||||||
|
(match int_of_string @@ String.trim line with
|
||||||
|
| exception _ -> fail "expected integer (length of bulk string)"
|
||||||
|
| i -> read_exact i @@ fun str -> return (Data.Bulk_string str))
|
||||||
|
| '*' ->
|
||||||
|
read_line @@ fun line ->
|
||||||
|
(match int_of_string @@ String.trim line with
|
||||||
|
| exception _ -> fail "expected integer (length of array)"
|
||||||
|
| i ->
|
||||||
|
let rec loop acc i =
|
||||||
|
if i = 0 then
|
||||||
|
return (Data.Array (List.rev acc))
|
||||||
|
else
|
||||||
|
cont_parser () >>= fun x -> loop (x :: acc) (i - 1)
|
||||||
|
in
|
||||||
|
loop [] i)
|
||||||
|
| c -> fail (Printf.sprintf "invalid command prefix %C" c)
|
||||||
|
|
||||||
|
let parse_string (str : string) : Data.t =
|
||||||
|
let rec run : type a b. int -> a action -> (int -> a -> b) -> b =
|
||||||
|
fun i act k ->
|
||||||
|
match act with
|
||||||
|
| Return x -> k i x
|
||||||
|
| Fail s -> failwith s
|
||||||
|
| Bind (x, f) -> run i x @@ fun i x -> run i (f x) k
|
||||||
|
| Read_char f ->
|
||||||
|
if i >= String.length str then failwith "unexpected EOF";
|
||||||
|
let c = str.[i] in
|
||||||
|
run (i + 1) (f c) k
|
||||||
|
| Read_line f ->
|
||||||
|
(match String.index_from str i '\n' with
|
||||||
|
| exception Not_found -> failwith "expected a line"
|
||||||
|
| j ->
|
||||||
|
let line = String.sub str i (j - i) in
|
||||||
|
run (j + 1) (f line) k)
|
||||||
|
| Read_exact (n, f) ->
|
||||||
|
if i + n > String.length str then failwith "not enough bytes";
|
||||||
|
let sub = String.sub str i n in
|
||||||
|
run (i + n) (f sub) k
|
||||||
|
in
|
||||||
|
run 0 (cont_parser ()) (fun _ x -> x)
|
||||||
|
|
||||||
|
let parse_chan (ic : in_channel) : Data.t =
|
||||||
|
let rec run : type a. a action -> a =
|
||||||
|
fun act ->
|
||||||
|
match act with
|
||||||
|
| Return x -> x
|
||||||
|
| Fail s -> failwith s
|
||||||
|
| Bind (x, f) ->
|
||||||
|
let x = run x in
|
||||||
|
run (f x)
|
||||||
|
| Read_char f ->
|
||||||
|
let c = input_char ic in
|
||||||
|
run (f c)
|
||||||
|
| Read_line f ->
|
||||||
|
let line = input_line ic in
|
||||||
|
run (f line)
|
||||||
|
| Read_exact (n, f) ->
|
||||||
|
let sub = really_input_string ic n in
|
||||||
|
run (f sub)
|
||||||
|
in
|
||||||
|
run (cont_parser ())
|
||||||
|
end
|
||||||
|
|
||||||
|
(*$= & ~printer:(CCFormat.to_string Data.pp)
|
||||||
|
Data.(Array [Simple_string "a"; Int 2]) (Parse.parse_string "*2\r\n+a\r\n:2\r\n")
|
||||||
|
*)
|
||||||
|
|
||||||
|
module Print = struct
|
||||||
|
type action =
|
||||||
|
| Return
|
||||||
|
| Write_char of char * (unit -> action)
|
||||||
|
| Write_line of string * (unit -> action)
|
||||||
|
| Write_string of string * (unit -> action)
|
||||||
|
| Bind of action * (unit -> action)
|
||||||
|
|
||||||
|
let return = Return
|
||||||
|
let[@inline] write_char c f = Write_char (c, f)
|
||||||
|
let[@inline] write_string s f = Write_string (s, f)
|
||||||
|
let[@inline] write_line s f = Write_line (s, f)
|
||||||
|
let[@inline] ( >>= ) x f = Bind (x, f)
|
||||||
|
|
||||||
|
let rec cont_printer (d : Data.t) : action =
|
||||||
|
match d with
|
||||||
|
| Data.Int i ->
|
||||||
|
write_char ':' @@ fun () ->
|
||||||
|
write_line (string_of_int i) @@ fun () -> return
|
||||||
|
| Data.Simple_string s ->
|
||||||
|
write_char '+' @@ fun () ->
|
||||||
|
write_line s @@ fun () -> return
|
||||||
|
| Data.Error s ->
|
||||||
|
write_char '-' @@ fun () ->
|
||||||
|
write_line s @@ fun () -> return
|
||||||
|
| Data.Bulk_string s ->
|
||||||
|
write_char '$' @@ fun () ->
|
||||||
|
write_line (string_of_int (String.length s)) @@ fun () ->
|
||||||
|
write_string s @@ fun () -> return
|
||||||
|
| Data.Array l ->
|
||||||
|
write_char '*' @@ fun () ->
|
||||||
|
write_line (string_of_int (List.length l)) @@ fun () ->
|
||||||
|
let rec loop = function
|
||||||
|
| [] -> return
|
||||||
|
| x :: tl -> cont_printer x >>= fun () -> loop tl
|
||||||
|
in
|
||||||
|
loop l
|
||||||
|
|
||||||
|
let to_string (d : Data.t) : string =
|
||||||
|
let buf = Buffer.create 32 in
|
||||||
|
let rec run (a : action) : unit =
|
||||||
|
match a with
|
||||||
|
| Return -> ()
|
||||||
|
| Write_char (c, f) ->
|
||||||
|
Buffer.add_char buf c;
|
||||||
|
run (f ())
|
||||||
|
| Write_line (s, f) ->
|
||||||
|
Buffer.add_string buf s;
|
||||||
|
Buffer.add_string buf "\r\n";
|
||||||
|
run (f ())
|
||||||
|
| Write_string (s, f) ->
|
||||||
|
Buffer.add_string buf s;
|
||||||
|
Buffer.add_string buf "\r\n";
|
||||||
|
run (f ())
|
||||||
|
| Bind (a, f) ->
|
||||||
|
run a;
|
||||||
|
run (f ())
|
||||||
|
in
|
||||||
|
run (cont_printer d);
|
||||||
|
Buffer.contents buf
|
||||||
|
|
||||||
|
let to_chan (oc : out_channel) (d : Data.t) : unit =
|
||||||
|
let rec run (a : action) : unit =
|
||||||
|
match a with
|
||||||
|
| Return -> ()
|
||||||
|
| Write_char (c, f) ->
|
||||||
|
output_char oc c;
|
||||||
|
run (f ())
|
||||||
|
| Write_line (s, f) ->
|
||||||
|
output_string oc s;
|
||||||
|
output_string oc "\r\n";
|
||||||
|
run (f ())
|
||||||
|
| Write_string (s, f) ->
|
||||||
|
output_string oc s;
|
||||||
|
output_string oc "\r\n";
|
||||||
|
run (f ())
|
||||||
|
| Bind (a, f) ->
|
||||||
|
run a;
|
||||||
|
run (f ())
|
||||||
|
in
|
||||||
|
run (cont_printer d)
|
||||||
|
end
|
||||||
|
|
||||||
|
(*$= & ~printer:(Printf.sprintf "%S")
|
||||||
|
"*2\r\n+a\r\n:2\r\n" (Print.to_string Data.(Array [Simple_string "a"; Int 2]))
|
||||||
|
*)
|
||||||
5
src/resp2/dune
Normal file
5
src/resp2/dune
Normal file
|
|
@ -0,0 +1,5 @@
|
||||||
|
|
||||||
|
(library
|
||||||
|
(name containers_resp2)
|
||||||
|
(public_name containers.resp2)
|
||||||
|
(synopsis "encoding and decoding for RESP2 (redis wire format)"))
|
||||||
Loading…
Add table
Reference in a new issue