├── .github └── workflows │ └── ocaml.yml ├── .gitignore ├── .ocamlformat ├── CHANGES.md ├── LICENSE.md ├── README.md ├── dune-project ├── examples └── mirage │ ├── config.ml │ └── unikernel.ml ├── resp-client.opam ├── resp-mirage.opam ├── resp-server.opam ├── resp-unix.opam ├── resp.opam ├── src ├── resp-client │ ├── dune │ ├── resp_client.ml │ ├── resp_client.mli │ └── resp_client_intf.ml ├── resp-mirage │ ├── dune │ ├── resp_mirage.ml │ └── resp_mirage.mli ├── resp-server │ ├── dune │ ├── resp_server.ml │ ├── resp_server.mli │ └── resp_server_intf.ml ├── resp-unix │ ├── dune │ ├── resp_unix.ml │ └── resp_unix.mli └── resp │ ├── dune │ ├── resp.ml │ ├── resp.mli │ └── resp_intf.ml └── test ├── dune ├── test.ml ├── test_unix.ml └── util.ml /.github/workflows/ocaml.yml: -------------------------------------------------------------------------------- 1 | name: 'OCaml tests' 2 | 3 | on: 4 | pull_request: 5 | branches: 6 | - master 7 | push: 8 | branches: 9 | - master 10 | jobs: 11 | run: 12 | name: Build 13 | runs-on: '${{ matrix.os }}' 14 | steps: 15 | - name: 'Checkout code' 16 | uses: actions/checkout@v2 17 | - id: ocaml-resp-opam-cache 18 | name: 'OCaml/Opam cache' 19 | uses: actions/cache@v2 20 | with: 21 | key: 'ocaml-resp-opam-${{ matrix.ocaml-version }}-${{ matrix.os }}' 22 | path: ~/.opam 23 | - name: 'Use OCaml ${{ matrix.ocaml-version }}' 24 | uses: avsm/setup-ocaml@v1 25 | with: 26 | ocaml-version: '${{ matrix.ocaml-version }}' 27 | - name: 'Set Opam env' 28 | run: 'opam env >> $GITHUB_ENV' 29 | - name: 'Add Opam switch to PATH' 30 | run: 'opam var bin >> $GITHUB_PATH' 31 | - run: 'OPAMSOLVERTIMEOUT=3600 opam install . --deps-only --with-test' 32 | - name: 'Run OCaml tests' 33 | run: 'opam exec -- dune runtest' 34 | strategy: 35 | fail-fast: true 36 | matrix: 37 | ocaml-version: 38 | - 4.13.1 39 | - 4.12.1 40 | - 4.11.1 41 | - 4.10.0 42 | os: 43 | - macos-latest 44 | - ubuntu-latest 45 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | tmp 3 | *~ 4 | \.\#* 5 | \#*# 6 | *.install 7 | *.native 8 | *.byte 9 | .merlin 10 | examples/mirage/* 11 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.19.0 2 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # v0.11.0 2 | - Updates for `Conduit` and `Cstruct` 3 | 4 | # v0.10.0 5 | - Updated conduit and alcotest 6 | - Cleanup `Resp.t` type 7 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018 Zach Shipko 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | resp — REdis Serialization Protocol library for OCaml 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | resp is an OCaml library for working with the [Redis Serialization Protocol](https://redis.io/topics/protocol). 6 | It provides a pure-OCaml streaming interface for building clients and servers that communicate using RESP. 7 | 8 | resp is distributed under the ISC license. 9 | 10 | Homepage: https://github.com/zshipko/resp 11 | 12 | ## Installation 13 | 14 | resp can be installed with `opam`: 15 | 16 | opam install resp 17 | 18 | If you don't use `opam` consult the [`opam`](opam) file for build 19 | instructions. 20 | 21 | ## Documentation 22 | 23 | The documentation and API reference is generated from the source 24 | interfaces. It can be consulted [online][doc] or via `odig doc 25 | resp`. 26 | 27 | [doc]: https://zshipko.github.io/resp 28 | 29 | ## Tests 30 | 31 | In the distribution sample programs and tests are located in the 32 | [`test`](test) directory. They can be built and run 33 | with: 34 | 35 | dune runtest 36 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name resp) 4 | -------------------------------------------------------------------------------- /examples/mirage/config.ml: -------------------------------------------------------------------------------- 1 | open Mirage 2 | 3 | let main = 4 | foreign 5 | ~packages: 6 | [ package "duration"; package "resp-mirage"; package "conduit-mirage" ] "Unikernel.Main" 7 | (pclock @-> conduit @-> job) 8 | 9 | let server = generic_stackv4v6 default_network |> conduit_direct 10 | 11 | let () = register "resp-server" [ main $ default_posix_clock $ server ] 12 | -------------------------------------------------------------------------------- /examples/mirage/unikernel.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | open Mirage_clock 3 | 4 | module Main (Clock : PCLOCK) (Conduit : Conduit_mirage.S) = struct 5 | module R = Resp_mirage.Make (Conduit) 6 | module Server = R.Server.Default 7 | 8 | let commands = 9 | [ 10 | ( "ping", 11 | fun _ client cmd nargs -> 12 | if nargs = 0 then Server.ok client 13 | else Server.recv client >>= fun x -> Server.send client x ); 14 | ] 15 | 16 | let start clock conduit = 17 | let port = 8888 in 18 | let server = `TCP port in 19 | Logs.info (fun f -> f "Starting server on port 8888"); 20 | let server = Server.create ~commands (conduit, server) () in 21 | Server.start server 22 | end 23 | -------------------------------------------------------------------------------- /resp-client.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Zach Shipko " 3 | authors: ["Zach Shipko "] 4 | homepage: "https://github.com/zshipko/resp" 5 | doc: "https://zshipko.github.io/resp" 6 | license: "ISC" 7 | dev-repo: "git+https://github.com/zshipko/resp.git" 8 | bug-reports: "https://github.com/zshipko/resp/issues" 9 | tags: ["redis" "protocol"] 10 | 11 | depends: 12 | [ 13 | "ocaml" {>= "4.07.0"} 14 | "dune" {>= "2.0.0"} 15 | "resp" {= version} 16 | ] 17 | 18 | build: 19 | [ 20 | ["dune" "build" "-p" name "-j" jobs] 21 | ] 22 | 23 | synopsis: """ 24 | Redis serialization protocol client library 25 | """ 26 | 27 | description: """ 28 | Redis protocol client library for Lwt 29 | """ 30 | -------------------------------------------------------------------------------- /resp-mirage.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Zach Shipko " 3 | authors: "Zach Shipko " 4 | license: "ISC" 5 | homepage: "https://github.com/zshipko/resp" 6 | doc: "https://zshipko.github.io/resp" 7 | bug-reports: "https://github.com/zshipko/resp/issues" 8 | depends: [ 9 | "ocaml" {>= "4.10.0"} 10 | "dune" {>= "2.0.0"} 11 | "resp" {= version} 12 | "resp-client" {= version} 13 | "resp-server" {= version} 14 | "lwt" 15 | "conduit-mirage" {>= "5.0.0"} 16 | ] 17 | build: ["dune" "build" "-p" name] 18 | dev-repo: "git+https://github.com/zshipko/resp.git" 19 | 20 | synopsis: """ 21 | Redis serialization protocol for MirageOS 22 | """ 23 | 24 | description: """ 25 | Redis protocol client library 26 | 27 | Create RESP clients and servers for MirageOS 28 | """ 29 | -------------------------------------------------------------------------------- /resp-server.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Zach Shipko " 3 | authors: ["Zach Shipko "] 4 | homepage: "https://github.com/zshipko/resp" 5 | doc: "https://zshipko.github.io/resp" 6 | license: "ISC" 7 | dev-repo: "git+https://github.com/zshipko/resp.git" 8 | bug-reports: "https://github.com/zshipko/resp/issues" 9 | tags: [] 10 | 11 | depends: 12 | [ 13 | "ocaml" {>= "4.07.0"} 14 | "dune" {> "2.0.0"} 15 | "resp" {= version} 16 | "resp-client" {= version} 17 | ] 18 | 19 | build: 20 | [ 21 | ["dune" "build" "-p" name "-j" jobs] 22 | ] 23 | 24 | synopsis: """ 25 | Redis serialization protocol server 26 | """ 27 | 28 | description: """ 29 | Redis protocol server 30 | 31 | Provides an interface for creating RESP servers 32 | """ 33 | -------------------------------------------------------------------------------- /resp-unix.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Zach Shipko " 3 | authors: "Zach Shipko " 4 | license: "ISC" 5 | homepage: "https://github.com/zshipko/resp" 6 | doc: "https://zshipko.github.io/resp" 7 | bug-reports: "https://github.com/zshipko/resp/issues" 8 | depends: [ 9 | "ocaml" {>= "4.10.0"} 10 | "dune" {>= "2.0.0"} 11 | "resp" {= version} 12 | "resp-client" {= version} 13 | "resp-server" {= version} 14 | "conduit-lwt-unix" {>= "5.0.0"} 15 | "alcotest" {with-test} 16 | "lwt" 17 | ] 18 | build: [ 19 | ["dune" "build" "-p" name "-j" jobs] 20 | ["dune" "runtest" "-p" name] {with-test} 21 | ] 22 | dev-repo: "git+https://github.com/zshipko/resp.git" 23 | 24 | synopsis: """ 25 | Redis serialization protocol for Unix 26 | """ 27 | 28 | description: """ 29 | Redis protocol for Unix 30 | 31 | Defines a Unix-compaible client and server using Lwt 32 | """ 33 | -------------------------------------------------------------------------------- /resp.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "Zach Shipko " 3 | authors: ["Zach Shipko "] 4 | homepage: "https://github.com/zshipko/resp" 5 | doc: "https://zshipko.github.io/resp" 6 | license: "ISC" 7 | dev-repo: "git+https://github.com/zshipko/resp.git" 8 | bug-reports: "https://github.com/zshipko/resp/issues" 9 | tags: [] 10 | 11 | depends: 12 | [ 13 | "ocaml" {>= "4.07.0"} 14 | "dune" {>= "2.0.0"} 15 | "lwt" 16 | "alcotest" {with-test & > "1.0.0"} 17 | ] 18 | 19 | depopts: [] 20 | 21 | build: 22 | [ 23 | ["dune" "build" "-p" name "-j" jobs] 24 | ] 25 | 26 | synopsis: """ 27 | Redis serialization protocol library 28 | """ 29 | 30 | description: """ 31 | Redis protocol client library 32 | 33 | This base package provides types and encoder/decoder 34 | """ 35 | -------------------------------------------------------------------------------- /src/resp-client/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name resp_client) 3 | (public_name resp-client) 4 | (libraries resp)) 5 | -------------------------------------------------------------------------------- /src/resp-client/resp_client.ml: -------------------------------------------------------------------------------- 1 | include Resp_client_intf 2 | 3 | module Make 4 | (Client : CLIENT) 5 | (S : Resp.S with type Reader.ic = Client.ic and type Writer.oc = Client.oc) = 6 | struct 7 | include S 8 | open Lwt 9 | 10 | type t = Client.ic * Client.oc 11 | 12 | type params = Client.params 13 | 14 | let connect params = Client.connect params 15 | 16 | let read (ic, _) = S.read ic 17 | 18 | let write (_, oc) = S.write oc 19 | 20 | let decode (ic, _) = S.Reader.decode ic 21 | 22 | let read_lexeme (ic, _) = 23 | S.Reader.read_lexeme ic >>= fun x -> Resp.unwrap x |> Lwt.return 24 | 25 | let run_s client cmd = 26 | let cmd = List.to_seq cmd |> Seq.map (fun s -> Resp.string s) in 27 | write client (Array cmd) >>= fun () -> read client 28 | 29 | let run client cmd = 30 | let cmd = List.to_seq cmd in 31 | write client (Array cmd) >>= fun () -> read client 32 | end 33 | -------------------------------------------------------------------------------- /src/resp-client/resp_client.mli: -------------------------------------------------------------------------------- 1 | include Resp_client_intf.Client 2 | -------------------------------------------------------------------------------- /src/resp-client/resp_client_intf.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | include Resp.S 3 | 4 | type t 5 | 6 | type params 7 | 8 | val connect : params -> t Lwt.t 9 | 10 | val read : t -> Resp.t Lwt.t 11 | 12 | val write : t -> Resp.t -> unit Lwt.t 13 | 14 | val run : t -> Resp.t list -> Resp.t Lwt.t 15 | 16 | val run_s : t -> string list -> Resp.t Lwt.t 17 | 18 | val decode : t -> Resp.lexeme -> Resp.t Lwt.t 19 | 20 | val read_lexeme : t -> Resp.lexeme Lwt.t 21 | end 22 | 23 | module type CLIENT = sig 24 | type ic 25 | 26 | type oc 27 | 28 | type params 29 | 30 | val connect : params -> (ic * oc) Lwt.t 31 | end 32 | 33 | module type Client = sig 34 | module type S = S 35 | 36 | module type CLIENT = CLIENT 37 | 38 | module Make 39 | (Client : CLIENT) 40 | (S : Resp.S with type Reader.ic = Client.ic and type Writer.oc = Client.oc) : 41 | S 42 | with module Reader = S.Reader 43 | and module Writer = S.Writer 44 | and type t = Client.ic * Client.oc 45 | and type params = Client.params 46 | end 47 | -------------------------------------------------------------------------------- /src/resp-mirage/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name resp_mirage) 3 | (public_name resp-mirage) 4 | (libraries resp resp-server resp-client lwt conduit-mirage)) 5 | -------------------------------------------------------------------------------- /src/resp-mirage/resp_mirage.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Make (C : Conduit_mirage.S) = struct 4 | type buffer = { flow : C.Flow.flow; mutable buffer : Cstruct.t } 5 | 6 | module Reader = Resp.Reader (struct 7 | type ic = buffer 8 | 9 | let update_buffer_if_needed t n = 10 | let buflen = Cstruct.length t.buffer in 11 | if buflen < n then 12 | C.Flow.read t.flow >|= function 13 | | Ok (`Data c) -> t.buffer <- Cstruct.append t.buffer c 14 | | Ok `Eof -> raise End_of_file 15 | | Error err -> 16 | let msg = Fmt.to_to_string C.Flow.pp_error err in 17 | raise (Resp.Exc (`Msg msg)) 18 | else Lwt.return_unit 19 | 20 | let get_string t n = 21 | let buflen = Cstruct.length t.buffer in 22 | if n > buflen then raise End_of_file 23 | else 24 | let c, d = Cstruct.split t.buffer n in 25 | t.buffer <- d; 26 | Cstruct.to_string c 27 | 28 | let read t n = update_buffer_if_needed t n >|= fun () -> get_string t n 29 | 30 | let read_char t = 31 | let rec aux () = 32 | let buflen = Cstruct.length t.buffer in 33 | if buflen > 0 then 34 | let c = Cstruct.get_char t.buffer 0 in 35 | let () = t.buffer <- Cstruct.sub t.buffer 1 (buflen - 1) in 36 | Lwt.return c 37 | else 38 | C.Flow.read t.flow >>= function 39 | | Ok (`Data c) -> 40 | t.buffer <- Cstruct.append t.buffer c; 41 | aux () 42 | | Ok `Eof -> raise End_of_file 43 | | Error err -> 44 | let msg = Fmt.to_to_string C.Flow.pp_error err in 45 | raise (Resp.Exc (`Msg msg)) 46 | in 47 | aux () 48 | 49 | let read_line t = 50 | let rec aux output = 51 | read t 1 >>= function 52 | | "\n" -> Lwt.return output 53 | | "\r" -> aux output 54 | | c -> aux (output ^ c) 55 | in 56 | aux "" 57 | end) 58 | 59 | module Writer = Resp.Writer (struct 60 | type oc = C.Flow.flow 61 | 62 | let write oc s = 63 | C.Flow.write oc (Cstruct.of_string s) >>= function 64 | | Ok () -> Lwt.return_unit 65 | | Error err -> 66 | let msg = Fmt.to_to_string C.Flow.pp_write_error err in 67 | raise (Resp.Exc (`Msg msg)) 68 | end) 69 | 70 | module Backend (Data : Resp_server.DATA) = struct 71 | include Data 72 | 73 | type ic = buffer 74 | 75 | type oc = C.Flow.flow 76 | 77 | type server = C.t * Conduit_mirage.server 78 | 79 | let run (ctx, server) fn = 80 | C.listen ctx server (fun flow -> 81 | let buffer = { flow; buffer = Cstruct.empty } in 82 | fn (buffer, flow)) 83 | end 84 | 85 | module Client_backend = struct 86 | open Lwt.Infix 87 | 88 | type ic = buffer 89 | 90 | type oc = C.Flow.flow 91 | 92 | type params = C.t * Conduit_mirage.client 93 | 94 | let connect (ctx, client) = 95 | C.connect ctx client >|= fun c -> ({ flow = c; buffer = Cstruct.empty }, c) 96 | end 97 | 98 | module Server = struct 99 | module Make (Auth : Resp_server.AUTH) (Data : Resp_server.DATA) = 100 | Resp_server.Make (Backend (Data)) (Auth) (Resp.Make (Reader) (Writer)) 101 | 102 | module Default = 103 | Make 104 | (Resp_server.Auth.String) 105 | (struct 106 | type data = unit 107 | end) 108 | end 109 | 110 | module Client = 111 | Resp_client.Make (Client_backend) (Resp.Make (Reader) (Writer)) 112 | end 113 | -------------------------------------------------------------------------------- /src/resp-mirage/resp_mirage.mli: -------------------------------------------------------------------------------- 1 | module Make (C : Conduit_mirage.S) : sig 2 | type buffer = { flow : C.Flow.flow; mutable buffer : Cstruct.t } 3 | 4 | module Reader : Resp.READER with type ic = buffer 5 | 6 | module Writer : Resp.WRITER with type oc = C.Flow.flow 7 | 8 | module Backend (Data : Resp_server.DATA) : 9 | Resp_server.SERVER 10 | with type oc = C.Flow.flow 11 | and type ic = buffer 12 | and type data = Data.data 13 | 14 | module Server : sig 15 | module Make (Auth : Resp_server.AUTH) (Data : Resp_server.DATA) : 16 | Resp_server.S 17 | with module Auth = Auth 18 | and type ic = Reader.ic 19 | and type oc = Writer.oc 20 | and type server = C.t * Conduit_mirage.server 21 | and type data = Data.data 22 | 23 | module Default : 24 | Resp_server.S 25 | with type Auth.t = string 26 | and type ic = Reader.ic 27 | and type oc = Writer.oc 28 | and type server = C.t * Conduit_mirage.server 29 | and type data = unit 30 | end 31 | 32 | module Client : 33 | Resp_client.S 34 | with type params = C.t * Conduit_mirage.client 35 | and type t = Reader.ic * Writer.oc 36 | end 37 | -------------------------------------------------------------------------------- /src/resp-server/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name resp_server) 3 | (public_name resp-server) 4 | (libraries resp resp-client)) 5 | -------------------------------------------------------------------------------- /src/resp-server/resp_server.ml: -------------------------------------------------------------------------------- 1 | include Resp_server_intf 2 | 3 | module Auth = struct 4 | module String = struct 5 | type t = string 6 | 7 | let check auth args = Array.length args > 0 && args.(0) = auth 8 | end 9 | 10 | module User = struct 11 | type t = (string, string) Hashtbl.t 12 | 13 | let check auth args = 14 | if Array.length args < 2 then false 15 | else 16 | match Hashtbl.find_opt auth args.(0) with 17 | | Some p -> p = args.(1) 18 | | None -> false 19 | end 20 | end 21 | 22 | module Make 23 | (Server : SERVER) 24 | (Auth : AUTH) 25 | (Value : Resp.S 26 | with type Reader.ic = Server.ic 27 | and type Writer.oc = Server.oc) = 28 | struct 29 | include Server 30 | module Value = Value 31 | module Auth = Auth 32 | 33 | let ( >>= ) = Lwt.( >>= ) 34 | 35 | type client = { data : Server.data; ic : ic; oc : oc } 36 | 37 | type command = data -> client -> string -> int -> unit Lwt.t 38 | 39 | type t = { 40 | server : server; 41 | data : data; 42 | auth : Auth.t option; 43 | commands : (string, command) Hashtbl.t; 44 | default : string; 45 | } 46 | 47 | let ok { oc; _ } = Value.write oc (Simple_string "OK") 48 | 49 | let error { oc; _ } msg = Value.write oc (Error (Printf.sprintf "ERR %s" msg)) 50 | 51 | let invalid_arguments client = error client "Invalid arguments" 52 | 53 | let send { oc; _ } x = Value.write oc x 54 | 55 | let recv { ic; _ } = Value.read ic 56 | 57 | let hashtbl_of_list l = 58 | let ht = Hashtbl.create (List.length l) in 59 | List.iter (fun (k, v) -> Hashtbl.replace ht (String.lowercase_ascii k) v) l; 60 | ht 61 | 62 | let create ?auth ?(commands = []) ?(default = "default") server data = 63 | let commands = hashtbl_of_list commands in 64 | { server; data; auth; commands; default } 65 | 66 | let check_auth auth args = 67 | match auth with Some auth -> Auth.check auth args | None -> true 68 | 69 | let split_command_s seq : string * string array = 70 | match seq () with 71 | | Seq.Nil -> invalid_arg "split_command_s" 72 | | Seq.Cons (x, next) -> 73 | let name = Resp.to_string_exn x |> String.lowercase_ascii in 74 | (name, Array.of_seq (Seq.map Resp.to_string_exn next)) 75 | 76 | let rec discard_n client n = 77 | if n > 0 then Value.read client.ic >>= fun _ -> discard_n client (n - 1) 78 | else Lwt.return () 79 | 80 | let finish client ~nargs used = discard_n client (nargs - used) 81 | 82 | let rec handle t (client : client) authenticated = 83 | let argc = ref 0 in 84 | Lwt.catch 85 | (fun () -> 86 | if not authenticated then handle_not_authenticated t client 87 | else 88 | Value.Reader.read_lexeme client.ic >>= function 89 | | Ok (`As n) -> ( 90 | argc := n - 1; 91 | Value.read client.ic >>= function 92 | | Simple_string s | Bulk (`String s) -> 93 | let s = String.lowercase_ascii s in 94 | let f = 95 | try Hashtbl.find t.commands s 96 | with Not_found -> Hashtbl.find t.commands t.default 97 | in 98 | f t.data client s !argc >>= fun () -> handle t client true 99 | | _ -> 100 | discard_n client !argc >>= fun () -> 101 | error client "invalid commands name" >>= fun () -> 102 | handle t client true) 103 | | Error e -> 104 | error client (Resp.string_of_error e) >>= fun () -> 105 | handle t client true 106 | | _ -> 107 | error client "invalid command format" >>= fun () -> 108 | handle t client true) 109 | (function 110 | | Resp.Exc exc -> 111 | error client (Resp.string_of_error exc) >>= fun () -> 112 | handle t client true 113 | | Not_found -> 114 | discard_n client !argc >>= fun () -> 115 | error client "command not found" >>= fun () -> handle t client true 116 | | Failure msg | Invalid_argument msg -> error client msg 117 | | End_of_file -> Lwt.return () 118 | | exc -> raise exc) 119 | 120 | and handle_not_authenticated t client = 121 | Value.read client.ic >>= function 122 | | Array arr -> ( 123 | let cmd, args = split_command_s arr in 124 | match (cmd, args) with 125 | | "auth", args -> 126 | if check_auth t.auth args then 127 | ok client >>= fun () -> handle t client true 128 | else 129 | error client "authentication required" >>= fun () -> 130 | handle t client false 131 | | _, _ -> 132 | error client "authentication required" >>= fun () -> 133 | handle t client false) 134 | | _ -> 135 | error client "authentication required" >>= fun () -> 136 | handle t client false 137 | 138 | let start t = 139 | run t.server (fun (ic, oc) -> 140 | let client = { ic; oc; data = t.data } in 141 | handle t client (t.auth = None)) 142 | end 143 | -------------------------------------------------------------------------------- /src/resp-server/resp_server.mli: -------------------------------------------------------------------------------- 1 | include Resp_server_intf.Server 2 | -------------------------------------------------------------------------------- /src/resp-server/resp_server_intf.ml: -------------------------------------------------------------------------------- 1 | module type AUTH = sig 2 | type t 3 | 4 | val check : t -> string array -> bool 5 | end 6 | 7 | module type DATA = sig 8 | type data 9 | end 10 | 11 | module type SERVER = sig 12 | type ic 13 | 14 | type oc 15 | 16 | type server 17 | 18 | include DATA 19 | 20 | val run : server -> (ic * oc -> unit Lwt.t) -> unit Lwt.t 21 | end 22 | 23 | module type S = sig 24 | include SERVER 25 | 26 | module Value : Resp.S with type Reader.ic = ic and type Writer.oc = oc 27 | 28 | module Auth : AUTH 29 | 30 | type client = { data : data; ic : ic; oc : oc } 31 | 32 | type command = data -> client -> string -> int -> unit Lwt.t 33 | 34 | val discard_n : client -> int -> unit Lwt.t 35 | 36 | val finish : client -> nargs:int -> int -> unit Lwt.t 37 | 38 | val ok : client -> unit Lwt.t 39 | 40 | val error : client -> string -> unit Lwt.t 41 | 42 | val invalid_arguments : client -> unit Lwt.t 43 | 44 | val send : client -> Resp.t -> unit Lwt.t 45 | 46 | val recv : client -> Resp.t Lwt.t 47 | 48 | type t 49 | 50 | val create : 51 | ?auth:Auth.t -> 52 | ?commands:(string * command) list -> 53 | ?default:string -> 54 | server -> 55 | data -> 56 | t 57 | 58 | val start : t -> unit Lwt.t 59 | end 60 | 61 | module type Server = sig 62 | module type SERVER = SERVER 63 | 64 | module type AUTH = AUTH 65 | 66 | module type DATA = DATA 67 | 68 | module Auth : sig 69 | module String : AUTH with type t = string 70 | 71 | module User : AUTH with type t = (string, string) Hashtbl.t 72 | end 73 | 74 | module type S = S 75 | 76 | module Make 77 | (Server : SERVER) 78 | (Auth : AUTH) 79 | (Value : Resp.S 80 | with type Reader.ic = Server.ic 81 | and type Writer.oc = Server.oc) : 82 | S 83 | with type server = Server.server 84 | and module Auth = Auth 85 | and type ic = Server.ic 86 | and type oc = Server.oc 87 | and module Value = Value 88 | and type data = Server.data 89 | end 90 | -------------------------------------------------------------------------------- /src/resp-unix/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name resp_unix) 3 | (public_name resp-unix) 4 | (libraries resp resp-server resp-client lwt conduit-lwt-unix)) 5 | -------------------------------------------------------------------------------- /src/resp-unix/resp_unix.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | module Reader = Resp.Reader (struct 4 | type ic = Lwt_io.input_channel 5 | 6 | let read ic n = Lwt_io.read ic ~count:n 7 | 8 | let read_char = Lwt_io.read_char 9 | 10 | let read_line ic = Lwt_io.read_line ic 11 | end) 12 | 13 | module Writer = Resp.Writer (struct 14 | type oc = Lwt_io.output_channel 15 | 16 | let write oc s = Lwt_io.write oc s >>= fun () -> Lwt_io.flush oc 17 | end) 18 | 19 | module Backend (Data : Resp_server.DATA) = struct 20 | include Data 21 | 22 | type ic = Lwt_io.input_channel 23 | 24 | type oc = Lwt_io.output_channel 25 | 26 | type server = Conduit_lwt_unix.ctx * Conduit_lwt_unix.server 27 | 28 | let run server fn = 29 | let mode = snd server in 30 | let ctx = fst server in 31 | let on_exn exc = Printexc.to_string exc |> print_endline in 32 | Conduit_lwt_unix.serve ~on_exn ~ctx ~mode (fun _ ic oc -> fn (ic, oc)) 33 | end 34 | 35 | module Client_backend = struct 36 | open Lwt.Infix 37 | 38 | type ic = Lwt_io.input_channel 39 | 40 | type oc = Lwt_io.output_channel 41 | 42 | type params = Conduit_lwt_unix.ctx * Conduit_lwt_unix.client 43 | 44 | let connect params = 45 | Conduit_lwt_unix.connect ~ctx:(fst params) (snd params) 46 | >|= fun (_, ic, oc) -> (ic, oc) 47 | end 48 | 49 | module Server = struct 50 | module Make (Auth : Resp_server.AUTH) (Data : Resp_server.DATA) = 51 | Resp_server.Make (Backend (Data)) (Auth) (Resp.Make (Reader) (Writer)) 52 | 53 | module Default = 54 | Make 55 | (Resp_server.Auth.String) 56 | (struct 57 | type data = unit 58 | end) 59 | end 60 | 61 | module Client = Resp_client.Make (Client_backend) (Resp.Make (Reader) (Writer)) 62 | -------------------------------------------------------------------------------- /src/resp-unix/resp_unix.mli: -------------------------------------------------------------------------------- 1 | module Reader : Resp.READER with type ic = Lwt_io.input_channel 2 | 3 | module Writer : Resp.WRITER with type oc = Lwt_io.output_channel 4 | 5 | module Backend (Data : Resp_server.DATA) : 6 | Resp_server.SERVER 7 | with type oc = Lwt_io.output_channel 8 | and type ic = Lwt_io.input_channel 9 | and type data = Data.data 10 | 11 | module Server : sig 12 | module Make (Auth : Resp_server.AUTH) (Data : Resp_server.DATA) : 13 | Resp_server.S 14 | with module Auth = Auth 15 | and type ic = Reader.ic 16 | and type oc = Writer.oc 17 | and type server = Conduit_lwt_unix.ctx * Conduit_lwt_unix.server 18 | and type data = Data.data 19 | 20 | module Default : 21 | Resp_server.S 22 | with type Auth.t = string 23 | and type ic = Reader.ic 24 | and type oc = Writer.oc 25 | and type server = Conduit_lwt_unix.ctx * Conduit_lwt_unix.server 26 | and type data = unit 27 | end 28 | 29 | module Client : 30 | Resp_client.S 31 | with type params = Conduit_lwt_unix.ctx * Conduit_lwt_unix.client 32 | and type t = Reader.ic * Writer.oc 33 | -------------------------------------------------------------------------------- /src/resp/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name resp) 3 | (public_name resp) 4 | (libraries lwt)) 5 | -------------------------------------------------------------------------------- /src/resp/resp.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 Zach Shipko. All rights reserved. Distributed under the 3 | ISC license, see terms at the end of the file. %%NAME%% %%VERSLwtN%% 4 | ---------------------------------------------------------------------------*) 5 | 6 | open Lwt.Infix 7 | include Resp_intf 8 | 9 | let pp_error fmt = function 10 | | `Msg s -> Format.fprintf fmt "%s" s 11 | | `Invalid_value -> Format.fprintf fmt "invalid value" 12 | | `Unexpected c -> Format.fprintf fmt "unexpected input: (%d)" (int_of_char c) 13 | | `Invalid_encoder -> Format.fprintf fmt "invalid encoder" 14 | 15 | let string_of_error x = 16 | let buf = Buffer.create 16 in 17 | let fmt = Format.formatter_of_buffer buf in 18 | pp_error fmt x; 19 | Format.pp_print_flush fmt (); 20 | Buffer.contents buf 21 | 22 | exception Exc of error 23 | 24 | let unwrap = function Ok x -> x | Error e -> raise (Exc e) 25 | 26 | module type INPUT = sig 27 | type ic 28 | 29 | val read : ic -> int -> string Lwt.t 30 | 31 | val read_line : ic -> string Lwt.t 32 | 33 | val read_char : ic -> char Lwt.t 34 | end 35 | 36 | module type OUTPUT = sig 37 | type oc 38 | 39 | val write : oc -> string -> unit Lwt.t 40 | end 41 | 42 | module type READER = sig 43 | include INPUT 44 | 45 | val read_lexeme : ic -> (lexeme, error) result Lwt.t 46 | 47 | val decode : ic -> lexeme -> t Lwt.t 48 | end 49 | 50 | module type WRITER = sig 51 | include OUTPUT 52 | 53 | val write_sep : oc -> unit Lwt.t 54 | 55 | val write_lexeme : oc -> lexeme -> unit Lwt.t 56 | 57 | val encode : oc -> t -> unit Lwt.t 58 | end 59 | 60 | module type S = sig 61 | module Reader : READER 62 | 63 | module Writer : WRITER 64 | 65 | val write : Writer.oc -> t -> unit Lwt.t 66 | 67 | val read : Reader.ic -> t Lwt.t 68 | end 69 | 70 | module Reader (I : INPUT) = struct 71 | include I 72 | 73 | let rec read_lexeme ic : (lexeme, error) result Lwt.t = 74 | I.read_char ic >>= function 75 | | ':' -> 76 | I.read_line ic >>= fun i -> 77 | let i = Int64.of_string i in 78 | Lwt.return @@ Ok (`Integer i) 79 | | '-' -> I.read_line ic >>= fun line -> Lwt.return @@ Ok (`Error line) 80 | | '+' -> 81 | I.read_line ic >>= fun line -> Lwt.return @@ Ok (`Simple_string line) 82 | | '*' -> 83 | I.read_line ic >>= fun i -> 84 | let i = int_of_string i in 85 | if i < 0 then Lwt.return @@ Ok `Nil else Lwt.return @@ Ok (`As i) 86 | | '$' -> 87 | I.read_line ic >>= fun i -> 88 | let i = int_of_string i in 89 | if i < 0 then Lwt.return @@ Ok `Nil else Lwt.return @@ Ok (`Bs i) 90 | | '\r' -> I.read_char ic >>= fun _ -> read_lexeme ic 91 | | c -> Lwt.return_error (`Unexpected c) 92 | 93 | let rec decode ic : lexeme -> t Lwt.t = function 94 | | `Nil -> Lwt.return Nil 95 | | `Integer i -> Lwt.return @@ Integer i 96 | | `Error e -> Lwt.return @@ Error e 97 | | `Simple_string s -> Lwt.return (Simple_string s) 98 | | `Bs len -> 99 | if len = 0 then Lwt.return (Bulk (`String "")) 100 | else read ic len >>= fun b -> Lwt.return @@ Bulk (`String b) 101 | | `As len -> 102 | if len = 0 then Lwt.return (Array Seq.empty) 103 | else 104 | let rec aux l = function 105 | | 0 -> Lwt.return l 106 | | n -> ( 107 | read_lexeme ic >>= function 108 | | Ok v -> decode ic v >>= fun x -> aux (x :: l) (n - 1) 109 | | Error err -> raise (Exc err)) 110 | in 111 | aux [] len >|= fun l -> Array (List.to_seq (List.rev l)) 112 | end 113 | 114 | module Writer (O : OUTPUT) = struct 115 | include O 116 | 117 | let ( >>= ) = Lwt.( >>= ) 118 | 119 | let write_sep oc = O.write oc "\r\n" 120 | 121 | let write_lexeme oc = function 122 | | `Nil -> O.write oc "*-1\r\n" 123 | | `Error e -> 124 | O.write oc "-" >>= fun () -> 125 | O.write oc e >>= fun () -> write_sep oc 126 | | `Integer i -> 127 | O.write oc ":" >>= fun () -> O.write oc (Printf.sprintf "%Ld\r\n" i) 128 | | `Bs len -> O.write oc (Printf.sprintf "$%d\r\n" len) 129 | | `As len -> O.write oc (Printf.sprintf "*%d\r\n" len) 130 | | `Simple_string s -> 131 | O.write oc "+" >>= fun () -> 132 | O.write oc s >>= fun () -> write_sep oc 133 | 134 | let rec encode oc = function 135 | | Nil -> write_lexeme oc `Nil 136 | | Error e -> write_lexeme oc (`Error e) 137 | | Simple_string s -> write_lexeme oc (`Simple_string s) 138 | | Integer i -> write_lexeme oc (`Integer i) 139 | | Bulk (`Bytes s) -> 140 | let len = Bytes.length s in 141 | write_lexeme oc (`Bs len) >>= fun () -> 142 | write oc (Bytes.unsafe_to_string s) >>= fun () -> write_sep oc 143 | | Bulk (`String s) -> 144 | let len = String.length s in 145 | write_lexeme oc (`Bs len) >>= fun () -> 146 | write oc s >>= fun () -> write_sep oc 147 | | Array seq -> 148 | let l = List.of_seq seq in 149 | let len = List.length l in 150 | let rec write l = 151 | match l with 152 | | [] -> Lwt.return () 153 | | hd :: tl -> encode oc hd >>= fun () -> write tl 154 | in 155 | write_lexeme oc (`As len) >>= fun () -> write l 156 | end 157 | 158 | module Make (Reader : READER) (Writer : WRITER) = struct 159 | module Reader = Reader 160 | module Writer = Writer 161 | 162 | let ( >>= ) = Lwt.( >>= ) 163 | 164 | let decode = Reader.decode 165 | 166 | let read ic = 167 | Reader.read_lexeme ic >>= function 168 | | Ok l -> decode ic l 169 | | Error e -> raise (Exc e) 170 | 171 | let encode = Writer.encode 172 | 173 | let write oc = encode oc 174 | end 175 | 176 | let is_nil = function Nil -> true | _ -> false 177 | 178 | let to_string = function 179 | | Simple_string s -> Ok s 180 | | Bulk (`String s) -> Ok s 181 | | Bulk (`Bytes b) -> Ok (Bytes.to_string b) 182 | | Integer i -> Ok (Int64.to_string i) 183 | | _ -> Error `Invalid_value 184 | 185 | let to_string_exn x = to_string x |> unwrap 186 | 187 | let to_bytes = function 188 | | Simple_string s -> Ok (Bytes.of_string s) 189 | | Bulk (`String s) -> Ok (Bytes.of_string s) 190 | | Bulk (`Bytes b) -> Ok b 191 | | _ -> Error `Invalid_value 192 | 193 | let to_bytes_exn x = to_bytes x |> unwrap 194 | 195 | let to_integer = function 196 | | Integer i -> Ok i 197 | | Simple_string s | Bulk (`String s) -> ( 198 | try Ok (Int64.of_string s) with _ -> Error `Invalid_value) 199 | | _ -> Error `Invalid_value 200 | 201 | let to_integer_exn x = to_integer x |> unwrap 202 | 203 | let to_float = function 204 | | Integer i -> Ok (Int64.to_float i) 205 | | Simple_string s | Bulk (`String s) -> ( 206 | try Ok (float_of_string s) with _ -> Error `Invalid_value) 207 | | Bulk (`Bytes b) -> ( 208 | try Ok (float_of_string (Bytes.unsafe_to_string b)) 209 | with _ -> Error `Invalid_value) 210 | | _ -> Error `Invalid_value 211 | 212 | let to_float_exn x = to_float x |> unwrap 213 | 214 | let to_seq f = function 215 | | Array a -> Ok (Seq.map f a) 216 | | _ -> Error `Invalid_value 217 | 218 | let to_seq_exn f x = to_seq f x |> unwrap 219 | 220 | let to_array f = function 221 | | Array a -> Ok (Array.of_seq (Seq.map f a)) 222 | | _ -> Error `Invalid_value 223 | 224 | let to_array_exn f x = to_array f x |> unwrap 225 | 226 | let to_list f = function 227 | | Array a -> Ok (Seq.map f a |> List.of_seq) 228 | | _ -> Error `Invalid_value 229 | 230 | let to_list_exn f x = to_list f x |> unwrap 231 | 232 | let to_alist (a : t -> 'a) (b : t -> 'b) : t -> (('a * 'b) list, error) result = 233 | function 234 | | Array seq -> ( 235 | let rec aux seq acc = 236 | match seq () with 237 | | Seq.Nil -> failwith "invalid value" 238 | | Seq.Cons (k, next) -> ( 239 | match next () with 240 | | Seq.Nil -> failwith "invalid value" 241 | | Seq.Cons (v, next) -> aux next ((a k, b v) :: acc)) 242 | in 243 | try Ok (aux seq []) 244 | with Failure s when s = "invalid value" -> Result.Error `Invalid_value) 245 | | _ -> Error `Invalid_value 246 | 247 | let to_alist_exn k v x = to_alist k v x |> unwrap 248 | 249 | let to_hashtbl k v a = 250 | match to_alist k v a with 251 | | Ok a -> 252 | let t = Hashtbl.create (List.length a) in 253 | List.iter (fun (k, v) -> Hashtbl.replace t k v) a; 254 | Ok t 255 | | Error e -> Error e 256 | 257 | let to_hashtbl_exn k v x = to_hashtbl k v x |> unwrap 258 | 259 | let nil = Nil 260 | 261 | let int i = Integer (Int64.of_int i) 262 | 263 | let int64 i = Integer i 264 | 265 | let float f = Simple_string (Float.to_string f) 266 | 267 | let bytes b = Bulk (`Bytes b) 268 | 269 | let string s = Bulk (`String s) 270 | 271 | let simple_string s = Simple_string s 272 | 273 | let list t l = Array (List.to_seq l |> Seq.map t) 274 | 275 | let array t a = Array (Array.to_seq a |> Seq.map t) 276 | 277 | let seq_cons i s () = Seq.Cons (i, s) 278 | 279 | let alist a b l = 280 | Array 281 | (List.fold_left 282 | (fun acc (k, v) -> seq_cons (a k) acc |> seq_cons (b v)) 283 | Seq.empty (List.rev l)) 284 | 285 | let hashtbl a b ht = 286 | Array 287 | (Hashtbl.fold 288 | (fun k v acc -> seq_cons (a k) acc |> seq_cons (b v)) 289 | ht Seq.empty) 290 | 291 | let id x = x 292 | 293 | let rec equal a b = 294 | match (a, b) with 295 | | Nil, Nil -> true 296 | | Integer a, Integer b -> Int64.equal a b 297 | | Simple_string a, Simple_string b -> String.equal a b 298 | | Bulk (`String a), Bulk (`String b) -> String.equal a b 299 | | Bulk (`Bytes a), Bulk (`Bytes b) -> Bytes.equal a b 300 | | Error a, Error b -> String.equal a b 301 | | Array a, Array b -> 302 | let rec inner a b = 303 | match (a (), b ()) with 304 | | Seq.Nil, Seq.Nil -> true 305 | | Seq.Nil, _ | _, Seq.Nil -> false 306 | | Seq.Cons (x, next), Seq.Cons (y, next') -> 307 | if equal x y then inner next next' else false 308 | in 309 | inner a b 310 | | _, _ -> false 311 | 312 | module String_writer = Writer (struct 313 | type oc = string ref 314 | 315 | let write oc s = 316 | oc := !oc ^ s; 317 | Lwt.return_unit 318 | end) 319 | 320 | module String_reader = Reader (struct 321 | type ic = string ref 322 | 323 | let read input i = 324 | Lwt.wrap (fun () -> 325 | let s = String.sub !input 0 i in 326 | input := String.sub !input i (String.length !input - i); 327 | s) 328 | 329 | let read_char input = read input 1 >|= fun c -> c.[0] 330 | 331 | let read_line t = 332 | let rec aux output = 333 | read t 1 >>= function 334 | | "\n" -> Lwt.return output 335 | | "\r" -> aux output 336 | | c -> aux (output ^ c) 337 | in 338 | aux "" 339 | end) 340 | 341 | module String = Make (String_reader) (String_writer) 342 | 343 | (*--------------------------------------------------------------------------- 344 | Copyright (c) 2018 Zach Shipko 345 | 346 | Permission to use, copy, modify, and/or distribute this software for any 347 | purpose with or without fee is hereby granted, provided that the above 348 | copyright notice and this permission notice appear in all copies. 349 | 350 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 351 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 352 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 353 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 354 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTLwtN OF CONTRACT, NEGLIGENCE 355 | OR OTHER TORTLwtUS ACTLwtN, ARISING OUT OF OR IN CONNECTLwtN WITH THE USE OR 356 | PERFORMANCE OF THIS SOFTWARE. 357 | ---------------------------------------------------------------------------*) 358 | -------------------------------------------------------------------------------- /src/resp/resp.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 Zach Shipko. All rights reserved. Distributed under the 3 | ISC license, see terms at the end of the file. %%NAME%% %%VERSLwtN%% 4 | ---------------------------------------------------------------------------*) 5 | 6 | (** REdis Serialization Protocol library for OCaml 7 | 8 | {e %%VERSLwtN%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 9 | 10 | (** {1 Resp} *) 11 | 12 | include Resp_intf.Resp 13 | 14 | (*--------------------------------------------------------------------------- 15 | Copyright (c) 2018 Zach Shipko 16 | 17 | Permission to use, copy, modify, and/or distribute this software for any 18 | purpose with or without fee is hereby granted, provided that the above 19 | copyright notice and this permission notice appear in all copies. 20 | 21 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 22 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 23 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 24 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 25 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTLwtN OF CONTRACT, NEGLIGENCE 26 | OR OTHER TORTLwtUS ACTLwtN, ARISING OUT OF OR IN CONNECTLwtN WITH THE USE OR 27 | PERFORMANCE OF THIS SOFTWARE. 28 | ---------------------------------------------------------------------------*) 29 | -------------------------------------------------------------------------------- /src/resp/resp_intf.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Nil 3 | | Integer of int64 4 | | Simple_string of string 5 | | Error of string 6 | | Bulk of [ `String of string | `Bytes of bytes ] 7 | | Array of t Seq.t 8 | 9 | type lexeme = 10 | [ `Nil 11 | | `Integer of int64 12 | | `Simple_string of string 13 | | `Error of string 14 | | `Bs of int 15 | | `As of int ] 16 | 17 | type error = 18 | [ `Msg of string | `Unexpected of char | `Invalid_value | `Invalid_encoder ] 19 | 20 | module type Resp = sig 21 | type t = 22 | | Nil 23 | | Integer of int64 24 | | Simple_string of string 25 | | Error of string 26 | | Bulk of [ `String of string | `Bytes of bytes ] 27 | | Array of t Seq.t 28 | 29 | type lexeme = 30 | [ `Nil 31 | | `Integer of int64 32 | | `Simple_string of string 33 | | `Error of string 34 | | `Bs of int 35 | | `As of int ] 36 | 37 | type error = 38 | [ `Msg of string | `Unexpected of char | `Invalid_value | `Invalid_encoder ] 39 | 40 | val pp_error : Format.formatter -> error -> unit 41 | 42 | val string_of_error : error -> string 43 | 44 | val unwrap : ('a, error) result -> 'a 45 | 46 | exception Exc of error 47 | 48 | module type INPUT = sig 49 | type ic 50 | 51 | val read : ic -> int -> string Lwt.t 52 | 53 | val read_line : ic -> string Lwt.t 54 | 55 | val read_char : ic -> char Lwt.t 56 | end 57 | 58 | module type OUTPUT = sig 59 | type oc 60 | 61 | val write : oc -> string -> unit Lwt.t 62 | end 63 | 64 | module type READER = sig 65 | include INPUT 66 | 67 | val read_lexeme : ic -> (lexeme, error) result Lwt.t 68 | 69 | val decode : ic -> lexeme -> t Lwt.t 70 | end 71 | 72 | module type WRITER = sig 73 | include OUTPUT 74 | 75 | val write_sep : oc -> unit Lwt.t 76 | 77 | val write_lexeme : oc -> lexeme -> unit Lwt.t 78 | 79 | val encode : oc -> t -> unit Lwt.t 80 | end 81 | 82 | module type S = sig 83 | module Reader : READER 84 | 85 | module Writer : WRITER 86 | 87 | val write : Writer.oc -> t -> unit Lwt.t 88 | 89 | val read : Reader.ic -> t Lwt.t 90 | end 91 | 92 | module Reader (I : INPUT) : READER with type ic = I.ic 93 | 94 | module Writer (O : OUTPUT) : WRITER with type oc = O.oc 95 | 96 | module Make (Reader : READER) (Writer : WRITER) : 97 | S with module Reader = Reader and module Writer = Writer 98 | 99 | module String_reader : READER with type ic = string ref 100 | 101 | module String_writer : WRITER with type oc = string ref 102 | 103 | module String : 104 | S with module Reader = String_reader and module Writer = String_writer 105 | 106 | val is_nil : t -> bool 107 | 108 | val to_string : t -> (string, error) result 109 | 110 | val to_string_exn : t -> string 111 | 112 | val to_bytes : t -> (bytes, error) result 113 | 114 | val to_bytes_exn : t -> bytes 115 | 116 | val to_integer : t -> (int64, error) result 117 | 118 | val to_integer_exn : t -> int64 119 | 120 | val to_float : t -> (float, error) result 121 | 122 | val to_float_exn : t -> float 123 | 124 | val to_array : (t -> 'b) -> t -> ('b array, error) result 125 | 126 | val to_array_exn : (t -> 'b) -> t -> 'b array 127 | 128 | val to_list : (t -> 'b) -> t -> ('b list, error) result 129 | 130 | val to_list_exn : (t -> 'b) -> t -> 'b list 131 | 132 | val to_seq : (t -> 'b) -> t -> ('b Seq.t, error) result 133 | 134 | val to_seq_exn : (t -> 'b) -> t -> 'b Seq.t 135 | 136 | val to_alist : (t -> 'k) -> (t -> 'v) -> t -> (('k * 'v) list, error) result 137 | 138 | val to_alist_exn : (t -> 'k) -> (t -> 'v) -> t -> ('k * 'v) list 139 | 140 | val to_hashtbl : 141 | (t -> 'k) -> (t -> 'v) -> t -> (('k, 'v) Hashtbl.t, error) result 142 | 143 | val to_hashtbl_exn : (t -> 'k) -> (t -> 'v) -> t -> ('k, 'v) Hashtbl.t 144 | 145 | val int : int -> t 146 | 147 | val int64 : int64 -> t 148 | 149 | val float : float -> t 150 | 151 | val bytes : bytes -> t 152 | 153 | val string : string -> t 154 | 155 | val simple_string : string -> t 156 | 157 | val nil : t 158 | 159 | val array : ('a -> t) -> 'a array -> t 160 | 161 | val list : ('a -> t) -> 'a list -> t 162 | 163 | val alist : ('k -> t) -> ('v -> t) -> ('k * 'v) list -> t 164 | 165 | val hashtbl : ('k -> t) -> ('v -> t) -> ('k, 'v) Hashtbl.t -> t 166 | 167 | val id : 'a -> 'a 168 | 169 | val equal : t -> t -> bool 170 | end 171 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name util) 3 | (libraries alcotest resp-server) 4 | (modules util)) 5 | 6 | (executables 7 | (libraries alcotest resp lwt.unix) 8 | (names test) 9 | (modules test)) 10 | 11 | (executables 12 | (libraries alcotest util resp-unix) 13 | (names test_unix) 14 | (modules test_unix)) 15 | 16 | (rule 17 | (alias runtest) 18 | (package resp) 19 | (deps test.exe) 20 | (action 21 | (run ./test.exe))) 22 | 23 | (rule 24 | (alias runtest) 25 | (package resp-unix) 26 | (deps test_unix.exe) 27 | (action 28 | (run ./test_unix.exe))) 29 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | module Value = Resp.String 2 | open Lwt.Infix 3 | open Resp 4 | 5 | let test_roundtrip _ = 6 | Lwt_main.run 7 | (let v = 8 | Resp.(list id) 9 | [ 10 | simple_string "x"; 11 | int64 123L; 12 | string "abc"; 13 | simple_string ""; 14 | string ""; 15 | array id [||]; 16 | array int64 [| 1L |]; 17 | alist string int64 [ ("a", 1L); ("b", 2L); ("c", 3L) ]; 18 | ] 19 | in 20 | let output = ref "" in 21 | Value.write output v >>= fun () -> 22 | print_endline !output; 23 | Value.read output >>= fun v' -> 24 | Value.write output v' >|= fun () -> 25 | print_endline !output; 26 | Alcotest.(check bool) "compare" true (equal v v')) 27 | 28 | let () = 29 | Alcotest.run "Resp" 30 | [ ("encoding", [ Alcotest.test_case "Roundtrip" `Quick test_roundtrip ]) ] 31 | -------------------------------------------------------------------------------- /test/test_unix.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2018 Zach Shipko. All rights reserved. Distributed under the 3 | ISC license, see terms at the end of the file. %%NAME%% %%VERSION%% 4 | ---------------------------------------------------------------------------*) 5 | open Lwt.Infix 6 | open Resp_unix 7 | 8 | module Server = 9 | Server.Make 10 | (Resp_server.Auth.String) 11 | (struct 12 | type data = (string, string) Hashtbl.t 13 | end) 14 | 15 | include Util.Make (Server) 16 | 17 | let client, pid = 18 | Lwt_main.run 19 | (match Unix.fork () with 20 | | -1 -> 21 | Printf.eprintf "Unable to fork process"; 22 | exit 1 23 | | 0 -> 24 | let server = `TCP (`Port 1234) in 25 | let data = Hashtbl.create 8 in 26 | let server = 27 | Server.create ~commands 28 | (Lazy.force Conduit_lwt_unix.default_ctx, server) 29 | data 30 | in 31 | Server.start server >|= fun () -> exit 0 32 | | pid -> 33 | Unix.sleep 1; 34 | let addr = Ipaddr.of_string_exn "127.0.0.1" in 35 | let params = 36 | (Lazy.force Conduit_lwt_unix.default_ctx, `TCP (`IP addr, `Port 1234)) 37 | in 38 | Client.connect params >|= fun client -> (client, pid)) 39 | 40 | let invalid_response () = Alcotest.fail "Invalid response type" 41 | 42 | let test_set _ = 43 | Lwt_main.run 44 | (Client.run_s client [ "set"; "abc"; "123" ] >|= function 45 | | Simple_string s -> Alcotest.(check string) "set OK" s "OK" 46 | | _ -> invalid_response ()) 47 | 48 | let test_get _ = 49 | Lwt_main.run 50 | (Client.run_s client [ "get"; "abc" ] >|= function 51 | | Bulk (`String s) -> Alcotest.(check string) "Value of abc" s "123" 52 | | _ -> invalid_response ()) 53 | 54 | let basic = 55 | [ 56 | Alcotest.test_case "Set" `Quick test_set; 57 | Alcotest.test_case "Get" `Quick test_get; 58 | ] 59 | 60 | let () = 61 | Alcotest.run ~and_exit:false "Resp_unix" [ ("basic", basic) ]; 62 | Unix.kill pid Sys.sigint 63 | 64 | (*--------------------------------------------------------------------------- 65 | Copyright (c) 2018 Zach Shipko 66 | 67 | Permission to use, copy, modify, and/or distribute this software for any 68 | purpose with or without fee is hereby granted, provided that the above 69 | copyright notice and this permission notice appear in all copies. 70 | 71 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH 72 | REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY 73 | AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, 74 | INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM 75 | LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR 76 | OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR 77 | PERFORMANCE OF THIS SOFTWARE. 78 | ---------------------------------------------------------------------------*) 79 | -------------------------------------------------------------------------------- /test/util.ml: -------------------------------------------------------------------------------- 1 | module Make (Server : Resp_server.S) = struct 2 | open Lwt.Infix 3 | 4 | let commands = 5 | [ 6 | ( "set", 7 | fun ht client _cmd nargs -> 8 | if nargs <> 2 then Server.invalid_arguments client 9 | else 10 | Server.recv client >>= fun key -> 11 | Server.recv client >>= fun value -> 12 | Hashtbl.replace ht (Resp.to_string_exn key) 13 | (Resp.to_string_exn value); 14 | Server.ok client ); 15 | ( "get", 16 | fun ht client _cmd nargs -> 17 | if nargs <> 1 then Server.invalid_arguments client 18 | else 19 | Server.recv client >>= fun key -> 20 | try 21 | let value = Hashtbl.find ht (Resp.to_string_exn key) in 22 | Server.send client (Bulk (`String value)) 23 | with Not_found -> Server.error client "Not found" ); 24 | ] 25 | end 26 | --------------------------------------------------------------------------------