├── .gitignore ├── test ├── pipeline_read │ ├── dune │ └── pipeline_read.ml └── integration │ ├── dune │ └── test.ml ├── src ├── dune ├── resp.ml ├── parser.ml ├── orewa.mli └── orewa.ml ├── .travis.yml ├── CHANGES.md ├── Makefile ├── .ocamlformat ├── dune-project ├── orewa.opam ├── README.md └── COPYING /.gitignore: -------------------------------------------------------------------------------- 1 | /_build/ 2 | /_opam/ 3 | /*.install 4 | .merlin 5 | dump.rdb 6 | appendonly.aof 7 | -------------------------------------------------------------------------------- /test/pipeline_read/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name pipeline_read) 3 | (preprocess 4 | (pps ppx_let)) 5 | (libraries core async orewa)) 6 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name orewa) 3 | (public_name orewa) 4 | (libraries core async) 5 | (preprocess 6 | (pps ppx_let ppx_deriving.show ppx_deriving.eq))) 7 | -------------------------------------------------------------------------------- /test/integration/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (preprocess 4 | (pps ppx_let ppx_deriving.show ppx_deriving.eq ppx_deriving.ord)) 5 | (libraries alcotest alcotest-async core async orewa)) 6 | 7 | (alias 8 | (name integration) 9 | (deps 10 | (:test test.exe)) 11 | (action 12 | (run %{test} --color=always))) 13 | -------------------------------------------------------------------------------- /test/pipeline_read/pipeline_read.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | let host = "localhost" 5 | 6 | let key = "testkey1" 7 | 8 | let rec req conn = 9 | match%bind Orewa.get conn key with 10 | | Ok _ -> req conn 11 | | Error _ -> 12 | eprintf "Done\n%!"; 13 | return () 14 | 15 | let main () = 16 | let%bind conn = Orewa.connect ?port:None ~host in 17 | let%bind _res = Orewa.set conn ~key "test" in 18 | let l = List.init 20 ~f:(fun _ -> req conn) in 19 | Deferred.List.all_unit l 20 | 21 | let () = 22 | Command.async 23 | ~summary:"Run continous read" 24 | (Command.Let_syntax.return (fun () -> main ())) 25 | |> Command.run 26 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: required 3 | services: 4 | - redis-server 5 | install: 6 | - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh 7 | script: bash -ex .travis-opam.sh 8 | cache: 9 | directories: 10 | - $HOME/.opam 11 | env: 12 | global: 13 | - PACKAGE=orewa 14 | - TESTS=true 15 | - POST_INSTALL_HOOK="opam reinstall --with-test orewa && make integration" 16 | matrix: 17 | - OCAML_VERSION=4.04 18 | - OCAML_VERSION=4.05 19 | - OCAML_VERSION=4.06 20 | - OCAML_VERSION=4.07 21 | - OCAML_VERSION=4.08 22 | - OCAML_VERSION=4.09 EXTRA_DEPS="ocamlformat.0.12" PRE_INSTALL_HOOK="make format" 23 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | 0.2.1 2 | ===== 3 | 4 | * Support all set commands as of Redis 5.0 5 | 6 | 0.2.0 7 | ===== 8 | 9 | * Implement pipelining while simplifying parsing: it is now possible to queue 10 | up a lot of requests to Redis that will be fulfilled in order (thanks, 11 | @andersfugmann) 12 | * Remove `` `Eof`` error code since it was semantically equal to `` 13 | `Connection_closed`` (@andersfugmann) 14 | * Added `Always` option to `SET` to explicitly specify the default 15 | 16 | 0.1.1 17 | ===== 18 | 19 | * Expose result of `SET` 20 | * Fix bug when setting non-existing key 21 | 22 | 0.1.0 23 | ===== 24 | 25 | * Initial release 26 | * Designed to be async thread-safe 27 | * Supports all string commands of Redis 5.0 and a few others 28 | * All implemented commands tested against an actual Redis server 29 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all 2 | all: ## Build the code 3 | dune build 4 | 5 | .PHONY: clean 6 | clean: ## Clean source tree 7 | dune clean 8 | 9 | .PHONY: integration 10 | integration: ## Run integration tests, requires Redis 11 | dune build @integration --force 12 | 13 | .PHONY: test 14 | test: integration ## Run the tests 15 | 16 | .PHONY: distrib 17 | distrib: ## Create a distribution tarball 18 | dune-release distrib 19 | 20 | .PHONY: tag 21 | tag: ## Tag the current release 22 | dune-release tag 23 | 24 | .PHONY: publish 25 | publish: ## Put the release on GitHub 26 | dune-release publish distrib 27 | 28 | .PHONY: format 29 | format: 30 | dune build @fmt --auto-promote @install 31 | 32 | .PHONY: help 33 | help: ## Show this help 34 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' 35 | -------------------------------------------------------------------------------- /src/resp.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | type redis_error = string [@@deriving show, eq] 5 | 6 | let crlf = "\r\n" 7 | 8 | type t = 9 | | String of string 10 | | Error of redis_error 11 | | Integer of int 12 | | Bulk of string 13 | | Array of t list 14 | | Null 15 | [@@deriving show, eq] 16 | 17 | let terminator = function 18 | | true -> crlf 19 | | false -> "" 20 | 21 | let rec encode = function 22 | | String s -> Printf.sprintf "+%s%s" s crlf 23 | | Error e -> Printf.sprintf "-%s%s" e crlf 24 | | Integer n -> Printf.sprintf ":%d%s" n crlf 25 | | Bulk s -> 26 | let len = String.length s in 27 | Printf.sprintf "$%d%s%s%s" len crlf s crlf 28 | | Array xs -> 29 | let payload = xs |> List.map ~f:encode |> String.concat in 30 | let len = List.length xs in 31 | Printf.sprintf "*%d%s%s%s" len crlf payload crlf 32 | | Null -> Printf.sprintf "$-1%s" crlf 33 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | break-cases=toplevel 2 | break-infix=fit-or-vertical 3 | doc-comments=before 4 | extension-sugar=preserve 5 | field-space=loose 6 | if-then-else=keyword-first 7 | indicate-nested-or-patterns=unsafe-no 8 | infix-precedence=parens 9 | leading-nested-match-parens=false 10 | let-and=sparse 11 | let-open=preserve 12 | margin=90 13 | ocp-indent-compat=true 14 | parens-tuple=multi-line-only 15 | parens-tuple-patterns=multi-line-only 16 | sequence-style=terminator 17 | type-decl=sparse 18 | wrap-fun-args=false 19 | module-item-spacing=sparse 20 | break-separators=after 21 | dock-collection-brackets=false 22 | space-around-lists=false 23 | space-around-records=false 24 | space-around-variants=false 25 | break-infix-before-func=false 26 | break-collection-expressions=fit-or-vertical 27 | exp-grouping=parens 28 | align-cases=false 29 | align-constructors-decl=false 30 | align-variants-decl=false 31 | sequence-blank-line=compact 32 | indent-after-in=0 33 | indicate-multiline-delimiters=no 34 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.10) 2 | (using fmt 1.1) 3 | (name orewa) 4 | (generate_opam_files true) 5 | (maintainers "Marek Kubica ") 6 | (authors "Marek Kubica ") 7 | (source (github Leonidas-from-XIV/orewa)) 8 | (bug_reports "https://github.com/Leonidas-from-XIV/orewa/issues") 9 | (documentation "https://leonidas-from-xiv.github.io/orewa/") 10 | (license LGPL-3.0-or-later) 11 | 12 | (package 13 | (name orewa) 14 | (depends 15 | (async (>= v0.11)) 16 | (core (>= v0.11)) 17 | (dune (>= 1.10)) 18 | (ppx_let (>= v0.11)) 19 | (alcotest (and :with-test (>= 0.8.4))) 20 | (alcotest-async (and :with-test (>= 0.8.2))) 21 | (fmt (and :with-test (>= 0.8.6))) 22 | (ppx_deriving (>= 4.2))) 23 | (synopsis "Async-friendly Redis client") 24 | (description "Async-friendly Redis client 25 | 26 | Orewa is a Redis client designed with cooperative multithreading in mind, thus 27 | operations are non-blocking by default. 28 | 29 | It also features an OCaml-friendly Redis API wrapping the stringly constructs 30 | of the Redis commands into a more typed and less fragile interface that does 31 | its best to provide a pleasant interface.")) 32 | -------------------------------------------------------------------------------- /orewa.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | build: [ 4 | ["dune" "subst"] {pinned} 5 | ["dune" "build" "-p" name "-j" jobs] 6 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 7 | ["dune" "build" "-p" name "@doc"] {with-doc} 8 | ] 9 | maintainer: ["Marek Kubica "] 10 | authors: ["Marek Kubica "] 11 | bug-reports: "https://github.com/Leonidas-from-XIV/orewa/issues" 12 | homepage: "https://github.com/Leonidas-from-XIV/orewa" 13 | doc: "https://leonidas-from-xiv.github.io/orewa/" 14 | license: "LGPL-3.0-or-later" 15 | dev-repo: "git+https://github.com/Leonidas-from-XIV/orewa.git" 16 | synopsis: "Async-friendly Redis client" 17 | description: """ 18 | Async-friendly Redis client 19 | 20 | Orewa is a Redis client designed with cooperative multithreading in mind, thus 21 | operations are non-blocking by default. 22 | 23 | It also features an OCaml-friendly Redis API wrapping the stringly constructs 24 | of the Redis commands into a more typed and less fragile interface that does 25 | its best to provide a pleasant interface.""" 26 | depends: [ 27 | "async" {>= "v0.11"} 28 | "core" {>= "v0.11"} 29 | "dune" {>= "1.10"} 30 | "ppx_let" {>= "v0.11"} 31 | "alcotest" {with-test & >= "0.8.4"} 32 | "alcotest-async" {with-test & >= "0.8.2"} 33 | "fmt" {with-test & >= "0.8.6"} 34 | "ppx_deriving" {>= "4.2"} 35 | ] 36 | -------------------------------------------------------------------------------- /src/parser.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | let read_char reader = 5 | match%map Reader.read_char reader with 6 | | `Ok c -> Ok c 7 | | `Eof -> Error `Connection_closed 8 | 9 | let read_string reader = 10 | match%map Reader.read_line reader with 11 | | `Eof -> Error `Connection_closed 12 | | `Ok s -> Ok s 13 | 14 | let flush_line reader = read_string reader |> Deferred.Result.map ~f:ignore 15 | 16 | let read_int reader = read_string reader |> Deferred.Result.map ~f:int_of_string 17 | 18 | let read_bulk ~len reader = 19 | let s = Bytes.create len in 20 | match%map Reader.really_read reader s with 21 | | `Eof _ -> Error `Connection_closed 22 | | `Ok -> Ok (Bytes.to_string s) 23 | 24 | let rec read_resp reader = 25 | let open Deferred.Result.Let_syntax in 26 | match%bind read_char reader with 27 | | '+' -> read_string reader |> Deferred.Result.map ~f:(fun s -> Resp.String s) 28 | | '-' -> read_string reader |> Deferred.Result.map ~f:(fun s -> Resp.Error s) 29 | | ':' -> read_int reader |> Deferred.Result.map ~f:(fun i -> Resp.Integer i) 30 | | '$' -> ( 31 | match%bind read_int reader with 32 | | -1 -> 33 | (* No extra newline *) 34 | return Resp.Null 35 | | len -> 36 | let%bind data = read_bulk ~len reader in 37 | let%bind () = flush_line reader in 38 | return (Resp.Bulk data)) 39 | | '*' -> 40 | let%bind length = read_int reader in 41 | let rec inner acc = function 42 | | 0 -> return acc 43 | | n -> 44 | let%bind elem = read_resp reader in 45 | inner (elem :: acc) (n - 1) 46 | in 47 | let%bind elements = inner [] length in 48 | return (Resp.Array (List.rev elements)) 49 | | unknown -> 50 | Log.Global.debug "Unparseable type tag %C" unknown; 51 | Deferred.return @@ Error `Unexpected 52 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Orewa 2 | 3 | [![Build Status](https://travis-ci.org/Leonidas-from-XIV/orewa.svg?branch=master)](https://travis-ci.org/Leonidas-from-XIV/orewa) 4 | 5 | 俺は - an Async friendly Redis binding in pure OCaml. 6 | 7 | ## Installation 8 | 9 | It is availaible on OPAM, just 10 | 11 | ```sh 12 | opam install orewa 13 | ``` 14 | 15 | and off you go! No need to install any native libraries or other dependencies. 16 | 17 | ## Usage 18 | 19 | To connect to a Redis server use `Orewa.connect` which will return a handle to 20 | a connection. From here you can use all the implemented Redis commands in 21 | `Orewa.*` and also close the connection with `Orewa.close`. Or just use 22 | `Orewa.with_connection` to handle connection handling for you. 23 | 24 | Orewa opts in to offering an OCaml-centric API, so the commands map to 25 | functions and these take typed arguments. So instead of distinguishing between 26 | seconds and millisecond variants, in Orewa both are represented by a time span 27 | type. Different options to commands are represented by ADTs, to avoid 28 | constructing invalid commands. The results are mapped into the most fitting 29 | OCaml data types. Orewa also avoids exceptions, so the signature will tell you 30 | exactly which error types are expected. 31 | 32 | ### Examples 33 | 34 | The integration test in `src/integration/test.ml` attempts to test all 35 | implemented commands, so it demonstrates how each of them can be used. 36 | 37 | ## Documentation 38 | 39 | The [API documentation](https://leonidas-from-xiv.github.io/orewa/) of the 40 | current release is available online. The naming of the functions follows the 41 | naming of [Redis commands](https://redis.io/commands) so it is simple to adapt 42 | from the Redis docs to OCaml. 43 | 44 | ## Roadmap 45 | 46 | Currently all commands from the string category in Redis 5 are implemented. 47 | Over time this set is meant to be expanded. If you need support for a specific 48 | command, submit a pull request. 49 | 50 | For a very preliminary draft of what could be coming over time here's a list of 51 | ideas: 52 | 53 | 1. Most (all?) sensible Redis commands 54 | 1. Transactions in Redis 55 | 1. Cluster support, maybe. Unlikely to happen any time soon. 56 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | This library is free software; you can redistribute it and/or modify 2 | it under the terms of the GNU Lesser General Public License (LGPL) as 3 | published by the Free Software Foundation; either version 3.0 of the 4 | License (see below), or (at your option) any later version. 5 | 6 | As a special exception to the GNU Lesser General Public License, you 7 | may link, statically or dynamically, a "work that uses the Library" 8 | with a publicly distributed version of the Library to produce an 9 | executable file containing portions of the Library, and distribute 10 | that executable file under terms of your choice, without any of the 11 | additional requirements listed in clause 4 of the GNU Lesser General 12 | Public License. By "a publicly distributed version of the Library", 13 | we mean either the unmodified Library as distributed by the copyright 14 | holder, or a modified version of the Library that is distributed under 15 | the conditions defined in clause 2 of the GNU Lesser General Public 16 | License. This exception does not however invalidate any other reasons 17 | why the executable file might be covered by the GNU Lesser General 18 | Public License. 19 | 20 | 21 | GNU LESSER GENERAL PUBLIC LICENSE 22 | Version 3, 29 June 2007 23 | 24 | Copyright (C) 2007 Free Software Foundation, Inc. 25 | Everyone is permitted to copy and distribute verbatim copies 26 | of this license document, but changing it is not allowed. 27 | 28 | 29 | This version of the GNU Lesser General Public License incorporates 30 | the terms and conditions of version 3 of the GNU General Public 31 | License, supplemented by the additional permissions listed below. 32 | 33 | 0. Additional Definitions. 34 | 35 | As used herein, "this License" refers to version 3 of the GNU Lesser 36 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 37 | General Public License. 38 | 39 | "The Library" refers to a covered work governed by this License, 40 | other than an Application or a Combined Work as defined below. 41 | 42 | An "Application" is any work that makes use of an interface provided 43 | by the Library, but which is not otherwise based on the Library. 44 | Defining a subclass of a class defined by the Library is deemed a mode 45 | of using an interface provided by the Library. 46 | 47 | A "Combined Work" is a work produced by combining or linking an 48 | Application with the Library. The particular version of the Library 49 | with which the Combined Work was made is also called the "Linked 50 | Version". 51 | 52 | The "Minimal Corresponding Source" for a Combined Work means the 53 | Corresponding Source for the Combined Work, excluding any source code 54 | for portions of the Combined Work that, considered in isolation, are 55 | based on the Application, and not on the Linked Version. 56 | 57 | The "Corresponding Application Code" for a Combined Work means the 58 | object code and/or source code for the Application, including any data 59 | and utility programs needed for reproducing the Combined Work from the 60 | Application, but excluding the System Libraries of the Combined Work. 61 | 62 | 1. Exception to Section 3 of the GNU GPL. 63 | 64 | You may convey a covered work under sections 3 and 4 of this License 65 | without being bound by section 3 of the GNU GPL. 66 | 67 | 2. Conveying Modified Versions. 68 | 69 | If you modify a copy of the Library, and, in your modifications, a 70 | facility refers to a function or data to be supplied by an Application 71 | that uses the facility (other than as an argument passed when the 72 | facility is invoked), then you may convey a copy of the modified 73 | version: 74 | 75 | a) under this License, provided that you make a good faith effort to 76 | ensure that, in the event an Application does not supply the 77 | function or data, the facility still operates, and performs 78 | whatever part of its purpose remains meaningful, or 79 | 80 | b) under the GNU GPL, with none of the additional permissions of 81 | this License applicable to that copy. 82 | 83 | 3. Object Code Incorporating Material from Library Header Files. 84 | 85 | The object code form of an Application may incorporate material from 86 | a header file that is part of the Library. You may convey such object 87 | code under terms of your choice, provided that, if the incorporated 88 | material is not limited to numerical parameters, data structure 89 | layouts and accessors, or small macros, inline functions and templates 90 | (ten or fewer lines in length), you do both of the following: 91 | 92 | a) Give prominent notice with each copy of the object code that the 93 | Library is used in it and that the Library and its use are 94 | covered by this License. 95 | 96 | b) Accompany the object code with a copy of the GNU GPL and this license 97 | document. 98 | 99 | 4. Combined Works. 100 | 101 | You may convey a Combined Work under terms of your choice that, 102 | taken together, effectively do not restrict modification of the 103 | portions of the Library contained in the Combined Work and reverse 104 | engineering for debugging such modifications, if you also do each of 105 | the following: 106 | 107 | a) Give prominent notice with each copy of the Combined Work that 108 | the Library is used in it and that the Library and its use are 109 | covered by this License. 110 | 111 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 112 | document. 113 | 114 | c) For a Combined Work that displays copyright notices during 115 | execution, include the copyright notice for the Library among 116 | these notices, as well as a reference directing the user to the 117 | copies of the GNU GPL and this license document. 118 | 119 | d) Do one of the following: 120 | 121 | 0) Convey the Minimal Corresponding Source under the terms of this 122 | License, and the Corresponding Application Code in a form 123 | suitable for, and under terms that permit, the user to 124 | recombine or relink the Application with a modified version of 125 | the Linked Version to produce a modified Combined Work, in the 126 | manner specified by section 6 of the GNU GPL for conveying 127 | Corresponding Source. 128 | 129 | 1) Use a suitable shared library mechanism for linking with the 130 | Library. A suitable mechanism is one that (a) uses at run time 131 | a copy of the Library already present on the user's computer 132 | system, and (b) will operate properly with a modified version 133 | of the Library that is interface-compatible with the Linked 134 | Version. 135 | 136 | e) Provide Installation Information, but only if you would otherwise 137 | be required to provide such information under section 6 of the 138 | GNU GPL, and only to the extent that such information is 139 | necessary to install and execute a modified version of the 140 | Combined Work produced by recombining or relinking the 141 | Application with a modified version of the Linked Version. (If 142 | you use option 4d0, the Installation Information must accompany 143 | the Minimal Corresponding Source and Corresponding Application 144 | Code. If you use option 4d1, you must provide the Installation 145 | Information in the manner specified by section 6 of the GNU GPL 146 | for conveying Corresponding Source.) 147 | 148 | 5. Combined Libraries. 149 | 150 | You may place library facilities that are a work based on the 151 | Library side by side in a single library together with other library 152 | facilities that are not Applications and are not covered by this 153 | License, and convey such a combined library under terms of your 154 | choice, if you do both of the following: 155 | 156 | a) Accompany the combined library with a copy of the same work based 157 | on the Library, uncombined with any other library facilities, 158 | conveyed under the terms of this License. 159 | 160 | b) Give prominent notice with the combined library that part of it 161 | is a work based on the Library, and explaining where to find the 162 | accompanying uncombined form of the same work. 163 | 164 | 6. Revised Versions of the GNU Lesser General Public License. 165 | 166 | The Free Software Foundation may publish revised and/or new versions 167 | of the GNU Lesser General Public License from time to time. Such new 168 | versions will be similar in spirit to the present version, but may 169 | differ in detail to address new problems or concerns. 170 | 171 | Each version is given a distinguishing version number. If the 172 | Library as you received it specifies that a certain numbered version 173 | of the GNU Lesser General Public License "or any later version" 174 | applies to it, you have the option of following the terms and 175 | conditions either of that published version or of any later version 176 | published by the Free Software Foundation. If the Library as you 177 | received it does not specify a version number of the GNU Lesser 178 | General Public License, you may choose any version of the GNU Lesser 179 | General Public License ever published by the Free Software Foundation. 180 | 181 | If the Library as you received it specifies that a proxy can decide 182 | whether future versions of the GNU Lesser General Public License shall 183 | apply, that proxy's public statement of acceptance of any version is 184 | permanent authorization for you to choose that version for the 185 | Library. 186 | -------------------------------------------------------------------------------- /src/orewa.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | type t 5 | 6 | type common_error = 7 | [ `Connection_closed 8 | | `Unexpected ] 9 | [@@deriving show, eq] 10 | 11 | type wrong_type = [`Wrong_type of string] [@@deriving show, eq] 12 | 13 | val echo : t -> string -> (string, [> common_error]) Deferred.Result.t 14 | 15 | val set 16 | : t -> 17 | key:string -> 18 | ?expire:Time.Span.t -> 19 | ?exist:[`Always | `Not_if_exists | `Only_if_exists] -> 20 | string -> 21 | (bool, [> common_error]) Deferred.Result.t 22 | 23 | val get : t -> string -> (string option, [> common_error]) Deferred.Result.t 24 | 25 | val getrange 26 | : t -> 27 | start:int -> 28 | end':int -> 29 | string -> 30 | (string, [> common_error]) Deferred.Result.t 31 | 32 | val getset 33 | : t -> 34 | key:string -> 35 | string -> 36 | (string option, [> common_error]) Deferred.Result.t 37 | 38 | val strlen : t -> string -> (int, [> common_error]) Deferred.Result.t 39 | 40 | val mget : t -> string list -> (string option list, [> common_error]) Deferred.Result.t 41 | 42 | val mset : t -> (string * string) list -> (unit, [> common_error]) Deferred.Result.t 43 | 44 | val msetnx : t -> (string * string) list -> (bool, [> common_error]) Deferred.Result.t 45 | 46 | val lpush 47 | : t -> 48 | ?exist:[`Always | `Only_if_exists] -> 49 | element:string -> 50 | ?elements:string list -> 51 | string -> 52 | (int, [> common_error | wrong_type]) Deferred.Result.t 53 | 54 | val rpush 55 | : t -> 56 | ?exist:[`Always | `Only_if_exists] -> 57 | element:string -> 58 | ?elements:string list -> 59 | string -> 60 | (int, [> common_error | wrong_type]) Deferred.Result.t 61 | 62 | val lpop : t -> string -> (string option, [> common_error | wrong_type]) Deferred.Result.t 63 | 64 | val rpop : t -> string -> (string option, [> common_error | wrong_type]) Deferred.Result.t 65 | 66 | val lrange 67 | : t -> 68 | key:string -> 69 | start:int -> 70 | stop:int -> 71 | (string list, [> common_error]) Deferred.Result.t 72 | 73 | val rpoplpush 74 | : t -> 75 | source:string -> 76 | destination:string -> 77 | (string, [> common_error | wrong_type]) Deferred.Result.t 78 | 79 | val append : t -> key:string -> string -> (int, [> common_error]) Deferred.Result.t 80 | 81 | val auth 82 | : t -> 83 | string -> 84 | (unit, [> `Redis_error of string | common_error]) Deferred.Result.t 85 | 86 | val bgrewriteaof : t -> (string, [> common_error]) Deferred.Result.t 87 | 88 | val bgsave : t -> (string, [> common_error]) Deferred.Result.t 89 | 90 | val bitcount 91 | : t -> 92 | ?range:int * int -> 93 | string -> 94 | (int, [> common_error]) Deferred.Result.t 95 | 96 | type overflow = 97 | | Wrap 98 | | Sat 99 | | Fail 100 | 101 | type intsize = 102 | | Signed of int 103 | | Unsigned of int 104 | 105 | type offset = 106 | | Absolute of int 107 | | Relative of int 108 | 109 | type fieldop = 110 | | Get of intsize * offset 111 | | Set of intsize * offset * int 112 | | Incrby of intsize * offset * int 113 | 114 | val bitfield 115 | : t -> 116 | ?overflow:overflow -> 117 | string -> 118 | fieldop list -> 119 | (int option list, [> common_error]) Deferred.Result.t 120 | 121 | type bitop = 122 | | AND 123 | | OR 124 | | XOR 125 | | NOT 126 | 127 | val bitop 128 | : t -> 129 | destkey:string -> 130 | ?keys:string list -> 131 | key:string -> 132 | bitop -> 133 | (int, [> common_error]) Deferred.Result.t 134 | 135 | type bit = 136 | | Zero 137 | | One 138 | [@@deriving show, eq] 139 | 140 | val bitpos 141 | : t -> 142 | ?start:int -> 143 | ?end':int -> 144 | string -> 145 | bit -> 146 | (int option, [> common_error]) Deferred.Result.t 147 | 148 | val getbit : t -> string -> int -> (bit, [> common_error]) Deferred.Result.t 149 | 150 | val setbit : t -> string -> int -> bit -> (bit, [> common_error]) Deferred.Result.t 151 | 152 | val decr : t -> string -> (int, [> common_error]) Deferred.Result.t 153 | 154 | val decrby : t -> string -> int -> (int, [> common_error]) Deferred.Result.t 155 | 156 | val incr : t -> string -> (int, [> common_error]) Deferred.Result.t 157 | 158 | val incrby : t -> string -> int -> (int, [> common_error]) Deferred.Result.t 159 | 160 | val incrbyfloat : t -> string -> float -> (float, [> common_error]) Deferred.Result.t 161 | 162 | val select : t -> int -> (unit, [> common_error]) Deferred.Result.t 163 | 164 | val del : t -> ?keys:string list -> string -> (int, [> common_error]) Deferred.Result.t 165 | 166 | val exists : t -> ?keys:string list -> string -> (int, [> common_error]) Deferred.Result.t 167 | 168 | val expire : t -> string -> Time.Span.t -> (int, [> common_error]) Deferred.Result.t 169 | 170 | val expireat : t -> string -> Time.t -> (int, [> common_error]) Deferred.Result.t 171 | 172 | val keys : t -> string -> (string list, [> common_error]) Deferred.Result.t 173 | 174 | val sadd 175 | : t -> 176 | key:string -> 177 | ?members:string list -> 178 | string -> 179 | (int, [> common_error]) Deferred.Result.t 180 | 181 | val scan : ?pattern:string -> ?count:int -> t -> string Pipe.Reader.t 182 | 183 | val scard : t -> string -> (int, [> common_error]) Deferred.Result.t 184 | 185 | val sdiff 186 | : t -> 187 | ?keys:string list -> 188 | string -> 189 | (string list, [> common_error]) Deferred.Result.t 190 | 191 | val sdiffstore 192 | : t -> 193 | destination:string -> 194 | ?keys:string list -> 195 | key:string -> 196 | (int, [> common_error]) Deferred.Result.t 197 | 198 | val sinter 199 | : t -> 200 | ?keys:string list -> 201 | string -> 202 | (string list, [> common_error]) Deferred.Result.t 203 | 204 | val sinterstore 205 | : t -> 206 | destination:string -> 207 | ?keys:string list -> 208 | key:string -> 209 | (int, [> common_error]) Deferred.Result.t 210 | 211 | val sismember : t -> key:string -> string -> (bool, [> common_error]) Deferred.Result.t 212 | 213 | val smembers : t -> string -> (string list, [> common_error]) Deferred.Result.t 214 | 215 | val smove 216 | : t -> 217 | source:string -> 218 | destination:string -> 219 | string -> 220 | (bool, [> common_error]) Deferred.Result.t 221 | 222 | val spop : t -> ?count:int -> string -> (string list, [> common_error]) Deferred.Result.t 223 | 224 | val srandmember 225 | : t -> 226 | ?count:int -> 227 | string -> 228 | (string list, [> common_error]) Deferred.Result.t 229 | 230 | val srem 231 | : t -> 232 | key:string -> 233 | ?members:string list -> 234 | string -> 235 | (int, [> common_error]) Deferred.Result.t 236 | 237 | val sunion 238 | : t -> 239 | ?keys:string list -> 240 | string -> 241 | (string list, [> common_error]) Deferred.Result.t 242 | 243 | val sunionstore 244 | : t -> 245 | destination:string -> 246 | ?keys:string list -> 247 | key:string -> 248 | (int, [> common_error]) Deferred.Result.t 249 | 250 | val sscan : t -> ?pattern:string -> ?count:int -> string -> string Pipe.Reader.t 251 | 252 | val move : t -> string -> int -> (bool, [> common_error]) Deferred.Result.t 253 | 254 | val persist : t -> string -> (bool, [> common_error]) Deferred.Result.t 255 | 256 | val randomkey : t -> (string, [> common_error]) Deferred.Result.t 257 | 258 | val rename : t -> string -> string -> (unit, [> common_error]) Deferred.Result.t 259 | 260 | val renamenx : t -> key:string -> string -> (bool, [> common_error]) Deferred.Result.t 261 | 262 | type order = 263 | | Asc 264 | | Desc 265 | 266 | val sort 267 | : t -> 268 | ?by:string -> 269 | ?limit:int * int -> 270 | ?get:string list -> 271 | ?order:order -> 272 | ?alpha:bool -> 273 | ?store:string -> 274 | string -> 275 | ([> `Count of int | `Sorted of string list], [> common_error]) Deferred.Result.t 276 | 277 | val ttl 278 | : t -> 279 | string -> 280 | ( Time.Span.t, 281 | [> `No_such_key of string | `Not_expiring of string | common_error] ) 282 | Deferred.Result.t 283 | 284 | val type' : t -> string -> (string option, [> common_error]) Deferred.Result.t 285 | 286 | val dump : t -> string -> (string option, [> common_error]) Deferred.Result.t 287 | 288 | val restore 289 | : t -> 290 | key:string -> 291 | ?ttl:Time.Span.t -> 292 | ?replace:bool -> 293 | string -> 294 | (unit, [> common_error]) Deferred.Result.t 295 | 296 | val lindex : t -> string -> int -> (string option, [> common_error]) Deferred.Result.t 297 | 298 | type position = 299 | | Before 300 | | After 301 | 302 | val linsert 303 | : t -> 304 | key:string -> 305 | position -> 306 | element:string -> 307 | pivot:string -> 308 | (int, [> common_error]) Deferred.Result.t 309 | 310 | val llen : t -> string -> (int, [> common_error]) Deferred.Result.t 311 | 312 | val lrem 313 | : t -> 314 | key:string -> 315 | int -> 316 | element:string -> 317 | (int, [> common_error]) Deferred.Result.t 318 | 319 | val lset 320 | : t -> 321 | key:string -> 322 | int -> 323 | element:string -> 324 | ( unit, 325 | [> common_error | `No_such_key of string | `Index_out_of_range of string] ) 326 | Deferred.Result.t 327 | 328 | val ltrim 329 | : t -> 330 | start:int -> 331 | end':int -> 332 | string -> 333 | (unit, [> common_error]) Deferred.Result.t 334 | 335 | val hset 336 | : t -> 337 | element:string * string -> 338 | ?elements:(string * string) list -> 339 | string -> 340 | (int, [> common_error]) Deferred.Result.t 341 | 342 | val hget : t -> field:string -> string -> (string, [> common_error]) Deferred.Result.t 343 | 344 | val hmget 345 | : t -> 346 | fields:string list -> 347 | string -> 348 | (string String.Map.t, [> common_error]) Deferred.Result.t 349 | 350 | val hgetall : t -> string -> (string String.Map.t, [> common_error]) Deferred.Result.t 351 | 352 | val hdel 353 | : t -> 354 | ?fields:string list -> 355 | field:string -> 356 | string -> 357 | (int, [> common_error]) Deferred.Result.t 358 | 359 | val hexists : t -> field:string -> string -> (bool, [> common_error]) Deferred.Result.t 360 | 361 | val hincrby 362 | : t -> 363 | field:string -> 364 | string -> 365 | int -> 366 | (int, [> common_error]) Deferred.Result.t 367 | 368 | val hincrbyfloat 369 | : t -> 370 | field:string -> 371 | string -> 372 | float -> 373 | (float, [> common_error]) Deferred.Result.t 374 | 375 | val hkeys : t -> string -> (string list, [> common_error]) Deferred.Result.t 376 | 377 | val hvals : t -> string -> (string list, [> common_error]) Deferred.Result.t 378 | 379 | val hlen : t -> string -> (int, [> common_error]) Deferred.Result.t 380 | 381 | val hstrlen : t -> field:string -> string -> (int, [> common_error]) Deferred.Result.t 382 | 383 | val hscan 384 | : t -> 385 | ?pattern:string -> 386 | ?count:int -> 387 | string -> 388 | (string * string) Pipe.Reader.t 389 | 390 | val publish : t -> channel:string -> string -> (int, [> common_error]) Deferred.Result.t 391 | 392 | val connect : ?port:int -> host:string -> t Deferred.t 393 | 394 | val close : t -> unit Deferred.t 395 | 396 | val with_connection : ?port:int -> host:string -> (t -> 'a Deferred.t) -> 'a Deferred.t 397 | -------------------------------------------------------------------------------- /src/orewa.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | type common_error = 5 | [ `Connection_closed 6 | | `Unexpected ] 7 | [@@deriving show, eq] 8 | 9 | type wrong_type = [`Wrong_type of string] [@@deriving show, eq] 10 | 11 | type response = (Resp.t, common_error) result 12 | 13 | type command = string list 14 | 15 | type request = 16 | { command : command; 17 | waiter : response Ivar.t } 18 | 19 | let construct_request commands = 20 | commands 21 | |> List.map ~f:(fun cmd -> Resp.Bulk cmd) 22 | |> (fun xs -> Resp.Array xs) 23 | |> Resp.encode 24 | 25 | type t = 26 | { (* Need a queue of waiter Ivars. Need some way of closing the connection *) 27 | waiters : response Ivar.t Queue.t; 28 | reader : request Pipe.Reader.t; 29 | writer : request Pipe.Writer.t } 30 | 31 | let init reader writer = 32 | let waiters = Queue.create () in 33 | let rec recv_loop reader = 34 | match%bind Monitor.try_with_or_error @@ fun () -> Parser.read_resp reader with 35 | | Error _ | Ok (Error _) -> return () 36 | | Ok (Ok r as result) -> ( 37 | match Queue.dequeue waiters with 38 | | None when Reader.is_closed reader -> return () 39 | | None -> failwithf "No waiters are waiting for this message: %s" (Resp.show r) () 40 | | Some waiter -> 41 | Ivar.fill waiter result; 42 | recv_loop reader) 43 | in 44 | (* Requests are posted to a pipe, and requests are processed in sequence *) 45 | let request_reader, request_writer = Pipe.create () in 46 | let handle_request {command; waiter} = 47 | Queue.enqueue waiters waiter; 48 | let request = construct_request command in 49 | return @@ Writer.write writer request 50 | in 51 | (* Start redis receiver. Processing ends if the connection is closed. *) 52 | don't_wait_for 53 | (let%bind () = recv_loop reader in 54 | return @@ Pipe.close request_writer); 55 | (* Start processing requests. Once the pipe is closed, we signal 56 | closed to all outstanding waiters after closing the underlying 57 | socket *) 58 | don't_wait_for 59 | (let%bind () = Pipe.iter request_reader ~f:handle_request in 60 | let%bind () = Writer.close writer in 61 | let%bind () = Reader.close reader in 62 | (* Signal this to all waiters. As the pipe has been closed, we 63 | know that no new waiters will arrive *) 64 | Queue.iter waiters ~f:(fun waiter -> Ivar.fill waiter @@ Error `Connection_closed); 65 | return @@ Queue.clear waiters); 66 | {waiters; reader = request_reader; writer = request_writer} 67 | 68 | let connect ?(port = 6379) ~host = 69 | let where = Tcp.Where_to_connect.of_host_and_port @@ Host_and_port.create ~host ~port in 70 | let%bind _socket, reader, writer = Tcp.connect where in 71 | return @@ init reader writer 72 | 73 | let close {writer; _} = return @@ Pipe.close writer 74 | 75 | let request t command = 76 | match Pipe.is_closed t.writer with 77 | | true -> return @@ Error `Connection_closed 78 | | false -> ( 79 | let waiter = Ivar.create () in 80 | let%bind () = Pipe.write t.writer {command; waiter} in 81 | (* Type coercion: [common_error] -> [> common_error] *) 82 | match%map Ivar.read waiter with 83 | | Ok _ as res -> res 84 | | Error `Connection_closed -> Error `Connection_closed 85 | | Error `Unexpected -> Error `Unexpected) 86 | 87 | let echo t message = 88 | let open Deferred.Result.Let_syntax in 89 | match%bind request t ["ECHO"; message] with 90 | | Resp.Bulk v -> return v 91 | | _ -> Deferred.return @@ Error `Unexpected 92 | 93 | let set t ~key ?expire ?(exist = `Always) value = 94 | let open Deferred.Result.Let_syntax in 95 | let expiry = 96 | match expire with 97 | | None -> [] 98 | | Some span -> ["PX"; span |> Time.Span.to_ms |> int_of_float |> string_of_int] 99 | in 100 | let existence = 101 | match exist with 102 | | `Always -> [] 103 | | `Not_if_exists -> ["NX"] 104 | | `Only_if_exists -> ["XX"] 105 | in 106 | let command = ["SET"; key; value] @ expiry @ existence in 107 | match%bind request t command with 108 | | Resp.Null -> return false 109 | | Resp.String "OK" -> return true 110 | | _ -> Deferred.return @@ Error `Unexpected 111 | 112 | let get t key = 113 | let open Deferred.Result.Let_syntax in 114 | match%bind request t ["GET"; key] with 115 | | Resp.Bulk v -> return @@ Some v 116 | | Resp.Null -> return @@ None 117 | | _ -> Deferred.return @@ Error `Unexpected 118 | 119 | let getrange t ~start ~end' key = 120 | let open Deferred.Result.Let_syntax in 121 | match%bind request t ["GETRANGE"; key; string_of_int start; string_of_int end'] with 122 | | Resp.Bulk v -> return v 123 | | _ -> Deferred.return @@ Error `Unexpected 124 | 125 | let getset t ~key value = 126 | let open Deferred.Result.Let_syntax in 127 | match%bind request t ["GETSET"; key; value] with 128 | | Resp.Bulk v -> return (Some v) 129 | | Resp.Null -> return None 130 | | _ -> Deferred.return @@ Error `Unexpected 131 | 132 | let strlen t key = 133 | let open Deferred.Result.Let_syntax in 134 | match%bind request t ["STRLEN"; key] with 135 | | Resp.Integer v -> return v 136 | | _ -> Deferred.return @@ Error `Unexpected 137 | 138 | let mget t keys = 139 | let open Deferred.Result.Let_syntax in 140 | match%bind request t ("MGET" :: keys) with 141 | | Resp.Array xs -> 142 | xs 143 | |> List.fold_right ~init:(Ok []) ~f:(fun item acc -> 144 | match acc with 145 | | Error _ -> acc 146 | | Ok acc -> ( 147 | match item with 148 | | Resp.Null -> Ok (None :: acc) 149 | | Resp.Bulk s -> Ok (Some s :: acc) 150 | | _ -> Error `Unexpected)) 151 | |> Deferred.return 152 | | _ -> Deferred.return @@ Error `Unexpected 153 | 154 | let mset t alist = 155 | let open Deferred.Result.Let_syntax in 156 | let payload = alist |> List.map ~f:(fun (k, v) -> [k; v]) |> List.concat in 157 | match%bind request t ("MSET" :: payload) with 158 | | Resp.String "OK" -> return () 159 | | _ -> Deferred.return @@ Error `Unexpected 160 | 161 | let msetnx t alist = 162 | let open Deferred.Result.Let_syntax in 163 | let payload = alist |> List.map ~f:(fun (k, v) -> [k; v]) |> List.concat in 164 | match%bind request t ("MSETNX" :: payload) with 165 | | Resp.Integer 1 -> return true 166 | | Resp.Integer 0 -> return false 167 | | _ -> Deferred.return @@ Error `Unexpected 168 | 169 | let is_wrong_type msg = String.is_prefix msg ~prefix:"WRONGTYPE" 170 | 171 | let omnidirectional_push command t ?(exist = `Always) ~element ?(elements = []) key = 172 | let open Deferred.Result.Let_syntax in 173 | let command = 174 | match exist with 175 | | `Always -> command 176 | | `Only_if_exists -> Printf.sprintf "%sX" command 177 | in 178 | match%bind request t ([command; key; element] @ elements) with 179 | | Resp.Integer n -> return n 180 | | Resp.Error e when is_wrong_type e -> Deferred.return (Error (`Wrong_type key)) 181 | | _ -> Deferred.return @@ Error `Unexpected 182 | 183 | let lpush = omnidirectional_push "LPUSH" 184 | 185 | let rpush = omnidirectional_push "RPUSH" 186 | 187 | let lrange t ~key ~start ~stop = 188 | let open Deferred.Result.Let_syntax in 189 | match%bind request t ["LRANGE"; key; string_of_int start; string_of_int stop] with 190 | | Resp.Array xs -> 191 | List.map xs ~f:(function 192 | | Resp.Bulk v -> Ok v 193 | | _ -> Error `Unexpected) 194 | |> Result.all 195 | |> Deferred.return 196 | | _ -> Deferred.return @@ Error `Unexpected 197 | 198 | let lrem t ~key count ~element = 199 | let open Deferred.Result.Let_syntax in 200 | match%bind request t ["LREM"; key; string_of_int count; element] with 201 | | Resp.Integer n -> return n 202 | | _ -> Deferred.return @@ Error `Unexpected 203 | 204 | let lset t ~key index ~element = 205 | let open Deferred.Result.Let_syntax in 206 | match%bind request t ["LSET"; key; string_of_int index; element] with 207 | | Resp.String "OK" -> return () 208 | | Resp.Error "ERR no such key" -> Deferred.return @@ Error (`No_such_key key) 209 | | Resp.Error "ERR index out of range" -> 210 | Deferred.return @@ Error (`Index_out_of_range key) 211 | | _ -> Deferred.return @@ Error `Unexpected 212 | 213 | let ltrim t ~start ~end' key = 214 | let open Deferred.Result.Let_syntax in 215 | match%bind request t ["LTRIM"; key; string_of_int start; string_of_int end'] with 216 | | Resp.String "OK" -> return () 217 | | _ -> Deferred.return @@ Error `Unexpected 218 | 219 | let rpoplpush t ~source ~destination = 220 | let open Deferred.Result.Let_syntax in 221 | match%bind request t ["RPOPLPUSH"; source; destination] with 222 | | Resp.Bulk element -> return element 223 | | Resp.Error e when is_wrong_type e -> 224 | let keys = Printf.sprintf "%s -> %s" source destination in 225 | Deferred.return (Error (`Wrong_type keys)) 226 | | _ -> Deferred.return @@ Error `Unexpected 227 | 228 | let append t ~key value = 229 | let open Deferred.Result.Let_syntax in 230 | match%bind request t ["APPEND"; key; value] with 231 | | Resp.Integer n -> return n 232 | | _ -> Deferred.return @@ Error `Unexpected 233 | 234 | let auth t password = 235 | let open Deferred.Result.Let_syntax in 236 | match%bind request t ["AUTH"; password] with 237 | | Resp.String "OK" -> return () 238 | | Resp.Error e -> Deferred.return @@ Error (`Redis_error e) 239 | | _ -> Deferred.return @@ Error `Unexpected 240 | 241 | let bgrewriteaof t = 242 | let open Deferred.Result.Let_syntax in 243 | match%bind request t ["BGREWRITEAOF"] with 244 | (* the documentation says it returns OK, but that's not true *) 245 | | Resp.String v -> return v 246 | | _ -> Deferred.return @@ Error `Unexpected 247 | 248 | let bgsave t = 249 | let open Deferred.Result.Let_syntax in 250 | match%bind request t ["BGSAVE"] with 251 | | Resp.String v -> return v 252 | | _ -> Deferred.return @@ Error `Unexpected 253 | 254 | let bitcount t ?range key = 255 | let open Deferred.Result.Let_syntax in 256 | let range = 257 | match range with 258 | | None -> [] 259 | | Some (start, end_) -> [string_of_int start; string_of_int end_] 260 | in 261 | match%bind request t (["BITCOUNT"; key] @ range) with 262 | | Resp.Integer n -> return n 263 | | _ -> Deferred.return @@ Error `Unexpected 264 | 265 | type overflow = 266 | | Wrap 267 | | Sat 268 | | Fail 269 | 270 | let string_of_overflow = function 271 | | Wrap -> "WRAP" 272 | | Sat -> "SAT" 273 | | Fail -> "FAIL" 274 | 275 | (* Declaration of type of the integer *) 276 | type intsize = 277 | | Signed of int 278 | | Unsigned of int 279 | 280 | let string_of_intsize = function 281 | | Signed v -> Printf.sprintf "i%d" v 282 | | Unsigned v -> Printf.sprintf "u%d" v 283 | 284 | type offset = 285 | | Absolute of int 286 | | Relative of int 287 | 288 | let string_of_offset = function 289 | | Absolute v -> string_of_int v 290 | | Relative v -> Printf.sprintf "#%d" v 291 | 292 | type fieldop = 293 | | Get of intsize * offset 294 | | Set of intsize * offset * int 295 | | Incrby of intsize * offset * int 296 | 297 | let bitfield t ?overflow key ops = 298 | let open Deferred.Result.Let_syntax in 299 | let ops = 300 | ops 301 | |> List.map ~f:(function 302 | | Get (size, offset) -> ["GET"; string_of_intsize size; string_of_offset offset] 303 | | Set (size, offset, value) -> 304 | [ "SET"; 305 | string_of_intsize size; 306 | string_of_offset offset; 307 | string_of_int value ] 308 | | Incrby (size, offset, increment) -> 309 | [ "INCRBY"; 310 | string_of_intsize size; 311 | string_of_offset offset; 312 | string_of_int increment ]) 313 | |> List.concat 314 | in 315 | let overflow = 316 | match overflow with 317 | | None -> [] 318 | | Some behaviour -> ["OVERFLOW"; string_of_overflow behaviour] 319 | in 320 | match%bind request t (["BITFIELD"; key] @ overflow @ ops) with 321 | | Resp.Array xs -> 322 | let open Result.Let_syntax in 323 | xs 324 | |> List.fold ~init:(Ok []) ~f:(fun acc v -> 325 | match acc, v with 326 | | Error _, _ -> acc 327 | | Ok acc, Resp.Integer i -> Ok (Some i :: acc) 328 | | Ok acc, Resp.Null -> Ok (None :: acc) 329 | | Ok _, _ -> Error `Unexpected) 330 | >>| List.rev 331 | |> Deferred.return 332 | | _ -> Deferred.return @@ Error `Unexpected 333 | 334 | type bitop = 335 | | AND 336 | | OR 337 | | XOR 338 | | NOT 339 | 340 | let string_of_bitop = function 341 | | AND -> "AND" 342 | | OR -> "OR" 343 | | XOR -> "XOR" 344 | | NOT -> "NOT" 345 | 346 | let bitop t ~destkey ?(keys = []) ~key op = 347 | let open Deferred.Result.Let_syntax in 348 | match%bind request t (["BITOP"; string_of_bitop op; destkey; key] @ keys) with 349 | | Resp.Integer n -> return n 350 | | _ -> Deferred.return @@ Error `Unexpected 351 | 352 | type bit = 353 | | Zero 354 | | One 355 | [@@deriving show, eq] 356 | 357 | let string_of_bit = function 358 | | Zero -> "0" 359 | | One -> "1" 360 | 361 | let bitpos t ?start ?end' key bit = 362 | let open Deferred.Result.Let_syntax in 363 | let%bind range = 364 | match start, end' with 365 | | Some s, Some e -> return [string_of_int s; string_of_int e] 366 | | Some s, None -> return [string_of_int s] 367 | | None, None -> return [] 368 | | None, Some _ -> raise (Invalid_argument "Can't specify end without start") 369 | in 370 | match%bind request t (["BITPOS"; key; string_of_bit bit] @ range) with 371 | | Resp.Integer -1 -> return None 372 | | Resp.Integer n -> return @@ Some n 373 | | _ -> Deferred.return @@ Error `Unexpected 374 | 375 | let getbit t key offset = 376 | let open Deferred.Result.Let_syntax in 377 | let offset = string_of_int offset in 378 | match%bind request t ["GETBIT"; key; offset] with 379 | | Resp.Integer 0 -> return Zero 380 | | Resp.Integer 1 -> return One 381 | | _ -> Deferred.return @@ Error `Unexpected 382 | 383 | let setbit t key offset value = 384 | let open Deferred.Result.Let_syntax in 385 | let offset = string_of_int offset in 386 | let value = string_of_bit value in 387 | match%bind request t ["SETBIT"; key; offset; value] with 388 | | Resp.Integer 0 -> return Zero 389 | | Resp.Integer 1 -> return One 390 | | _ -> Deferred.return @@ Error `Unexpected 391 | 392 | let decr t key = 393 | let open Deferred.Result.Let_syntax in 394 | match%bind request t ["DECR"; key] with 395 | | Resp.Integer n -> return n 396 | | _ -> Deferred.return @@ Error `Unexpected 397 | 398 | let decrby t key decrement = 399 | let open Deferred.Result.Let_syntax in 400 | match%bind request t ["DECRBY"; key; string_of_int decrement] with 401 | | Resp.Integer n -> return n 402 | | _ -> Deferred.return @@ Error `Unexpected 403 | 404 | let incr t key = 405 | let open Deferred.Result.Let_syntax in 406 | match%bind request t ["INCR"; key] with 407 | | Resp.Integer n -> return n 408 | | _ -> Deferred.return @@ Error `Unexpected 409 | 410 | let incrby t key increment = 411 | let open Deferred.Result.Let_syntax in 412 | match%bind request t ["INCRBY"; key; string_of_int increment] with 413 | | Resp.Integer n -> return n 414 | | _ -> Deferred.return @@ Error `Unexpected 415 | 416 | let incrbyfloat t key increment = 417 | let open Deferred.Result.Let_syntax in 418 | match%bind request t ["INCRBYFLOAT"; key; string_of_float increment] with 419 | | Resp.Bulk v -> return @@ float_of_string v 420 | | _ -> Deferred.return @@ Error `Unexpected 421 | 422 | let select t index = 423 | let open Deferred.Result.Let_syntax in 424 | match%bind request t ["SELECT"; string_of_int index] with 425 | | Resp.String "OK" -> return () 426 | | _ -> Deferred.return @@ Error `Unexpected 427 | 428 | let del t ?(keys = []) key = 429 | let open Deferred.Result.Let_syntax in 430 | match%bind request t (["DEL"; key] @ keys) with 431 | | Resp.Integer n -> return n 432 | | _ -> Deferred.return @@ Error `Unexpected 433 | 434 | let exists t ?(keys = []) key = 435 | let open Deferred.Result.Let_syntax in 436 | match%bind request t (["EXISTS"; key] @ keys) with 437 | | Resp.Integer n -> return n 438 | | _ -> Deferred.return @@ Error `Unexpected 439 | 440 | let expire t key span = 441 | let open Deferred.Result.Let_syntax in 442 | let milliseconds = Time.Span.to_ms span in 443 | (* rounded to nearest millisecond *) 444 | let expire = Printf.sprintf "%.0f" milliseconds in 445 | match%bind request t ["PEXPIRE"; key; expire] with 446 | | Resp.Integer n -> return n 447 | | _ -> Deferred.return @@ Error `Unexpected 448 | 449 | let expireat t key dt = 450 | let open Deferred.Result.Let_syntax in 451 | let since_epoch = dt |> Time.to_span_since_epoch |> Time.Span.to_ms in 452 | let expire = Printf.sprintf "%.0f" since_epoch in 453 | match%bind request t ["PEXPIREAT"; key; expire] with 454 | | Resp.Integer n -> return n 455 | | _ -> Deferred.return @@ Error `Unexpected 456 | 457 | let coerce_bulk_array xs = 458 | xs 459 | |> List.map ~f:(function 460 | | Resp.Bulk key -> Ok key 461 | | _ -> Error `Unexpected) 462 | |> Result.all 463 | 464 | let keys t pattern = 465 | let open Deferred.Result.Let_syntax in 466 | match%bind request t ["KEYS"; pattern] with 467 | | Resp.Array xs -> xs |> coerce_bulk_array |> Deferred.return 468 | | _ -> Deferred.return @@ Error `Unexpected 469 | 470 | let sadd t ~key ?(members = []) member = 471 | let open Deferred.Result.Let_syntax in 472 | match%bind request t ("SADD" :: key :: member :: members) with 473 | | Resp.Integer n -> return n 474 | | _ -> Deferred.return @@ Error `Unexpected 475 | 476 | let scard t key = 477 | let open Deferred.Result.Let_syntax in 478 | match%bind request t ["SCARD"; key] with 479 | | Resp.Integer n -> return n 480 | | _ -> Deferred.return @@ Error `Unexpected 481 | 482 | let generic_setop setop t ?(keys = []) key = 483 | let open Deferred.Result.Let_syntax in 484 | match%bind request t (setop :: key :: keys) with 485 | | Resp.Array res -> res |> coerce_bulk_array |> Deferred.return 486 | | _ -> Deferred.return @@ Error `Unexpected 487 | 488 | let sdiff = generic_setop "SDIFF" 489 | 490 | let generic_setop_store setop t ~destination ?(keys = []) ~key = 491 | let open Deferred.Result.Let_syntax in 492 | match%bind request t (setop :: destination :: key :: keys) with 493 | | Resp.Integer n -> return n 494 | | _ -> Deferred.return @@ Error `Unexpected 495 | 496 | let sdiffstore = generic_setop_store "SDIFFSTORE" 497 | 498 | let sinter = generic_setop "SINTER" 499 | 500 | let sinterstore = generic_setop_store "SINTERSTORE" 501 | 502 | let sismember t ~key member = 503 | let open Deferred.Result.Let_syntax in 504 | match%bind request t ["SISMEMBER"; key; member] with 505 | | Resp.Integer 0 -> return false 506 | | Resp.Integer 1 -> return true 507 | | _ -> Deferred.return @@ Error `Unexpected 508 | 509 | let smembers t key = 510 | let open Deferred.Result.Let_syntax in 511 | match%bind request t ["SMEMBERS"; key] with 512 | | Resp.Array res -> res |> coerce_bulk_array |> Deferred.return 513 | | _ -> Deferred.return @@ Error `Unexpected 514 | 515 | let smove t ~source ~destination member = 516 | let open Deferred.Result.Let_syntax in 517 | match%bind request t ["SISMEMBER"; source; destination; member] with 518 | | Resp.Integer 0 -> return false 519 | | Resp.Integer 1 -> return true 520 | | _ -> Deferred.return @@ Error `Unexpected 521 | 522 | let spop t ?(count = 1) key = 523 | let open Deferred.Result.Let_syntax in 524 | match%bind request t ["SPOP"; key; string_of_int count] with 525 | | Resp.Array res -> res |> coerce_bulk_array |> Deferred.return 526 | | _ -> Deferred.return @@ Error `Unexpected 527 | 528 | let srandmember t ?(count = 1) key = 529 | let open Deferred.Result.Let_syntax in 530 | match%bind request t ["SRANDMEMBER"; key; string_of_int count] with 531 | | Resp.Array res -> res |> coerce_bulk_array |> Deferred.return 532 | | _ -> Deferred.return @@ Error `Unexpected 533 | 534 | let srem t ~key ?(members = []) member = 535 | let open Deferred.Result.Let_syntax in 536 | match%bind request t ("SREM" :: key :: member :: members) with 537 | | Resp.Integer n -> return n 538 | | _ -> Deferred.return @@ Error `Unexpected 539 | 540 | let sunion = generic_setop "SUNION" 541 | 542 | let sunionstore = generic_setop_store "SUNIONSTORE" 543 | 544 | let generic_scan t ?pattern ?count over = 545 | let pattern = 546 | match pattern with 547 | | Some pattern -> ["MATCH"; pattern] 548 | | None -> [] 549 | in 550 | let count = 551 | match count with 552 | | Some count -> ["COUNT"; string_of_int count] 553 | | None -> [] 554 | in 555 | Pipe.create_reader ~close_on_exception:false @@ fun writer -> 556 | Deferred.repeat_until_finished "0" @@ fun cursor -> 557 | match%bind request t (over @ [cursor] @ pattern @ count) with 558 | | Ok (Resp.Array [Resp.Bulk cursor; Resp.Array from]) -> ( 559 | let from = 560 | from 561 | |> List.map ~f:(function 562 | | Resp.Bulk s -> s 563 | | _ -> failwith "unexpected") 564 | |> Queue.of_list 565 | in 566 | let%bind () = Pipe.transfer_in writer ~from in 567 | match cursor with 568 | | "0" -> return @@ `Finished () 569 | | cursor -> return @@ `Repeat cursor) 570 | | _ -> failwith "unexpected" 571 | 572 | let scan ?pattern ?count t = generic_scan t ?pattern ?count ["SCAN"] 573 | 574 | let sscan t ?pattern ?count key = generic_scan t ?pattern ?count ["SSCAN"; key] 575 | 576 | let hscan t ?pattern ?count key = 577 | let reader = generic_scan t ?pattern ?count ["HSCAN"; key] in 578 | Pipe.create_reader ~close_on_exception:true (fun writer -> 579 | let transfer_one_binding () = 580 | match%bind Pipe.read_exactly reader ~num_values:2 with 581 | | `Eof -> return @@ `Finished (Pipe.close writer) 582 | | `Fewer _ -> failwith "Unexpected protocol failure" 583 | | `Exactly q -> 584 | let field = Queue.get q 0 in 585 | let value = Queue.get q 1 in 586 | let binding = field, value in 587 | let%bind () = Pipe.write writer binding in 588 | return (`Repeat ()) 589 | in 590 | Deferred.repeat_until_finished () transfer_one_binding) 591 | 592 | let move t key db = 593 | let open Deferred.Result.Let_syntax in 594 | match%bind request t ["MOVE"; key; string_of_int db] with 595 | | Resp.Integer 0 -> return false 596 | | Resp.Integer 1 -> return true 597 | | _ -> Deferred.return @@ Error `Unexpected 598 | 599 | let persist t key = 600 | let open Deferred.Result.Let_syntax in 601 | match%bind request t ["PERSIST"; key] with 602 | | Resp.Integer 0 -> return false 603 | | Resp.Integer 1 -> return true 604 | | _ -> Deferred.return @@ Error `Unexpected 605 | 606 | let randomkey t = 607 | let open Deferred.Result.Let_syntax in 608 | match%bind request t ["RANDOMKEY"] with 609 | | Resp.Bulk s -> return s 610 | | _ -> Deferred.return @@ Error `Unexpected 611 | 612 | let rename t key newkey = 613 | let open Deferred.Result.Let_syntax in 614 | match%bind request t ["RENAME"; key; newkey] with 615 | | Resp.String "OK" -> return () 616 | | _ -> Deferred.return @@ Error `Unexpected 617 | 618 | let renamenx t ~key newkey = 619 | let open Deferred.Result.Let_syntax in 620 | match%bind request t ["RENAMENX"; key; newkey] with 621 | | Resp.Integer 0 -> return false 622 | | Resp.Integer 1 -> return true 623 | | _ -> Deferred.return @@ Error `Unexpected 624 | 625 | type order = 626 | | Asc 627 | | Desc 628 | 629 | let sort t ?by ?limit ?get ?order ?alpha ?store key = 630 | let open Deferred.Result.Let_syntax in 631 | let by = 632 | match by with 633 | | None -> [] 634 | | Some by -> ["BY"; by] 635 | in 636 | let limit = 637 | match limit with 638 | | None -> [] 639 | | Some (offset, count) -> ["LIMIT"; string_of_int offset; string_of_int count] 640 | in 641 | let get = 642 | match get with 643 | | None -> [] 644 | | Some patterns -> 645 | patterns |> List.map ~f:(fun pattern -> ["GET"; pattern]) |> List.concat 646 | in 647 | let order = 648 | match order with 649 | | None -> [] 650 | | Some Asc -> ["ASC"] 651 | | Some Desc -> ["DESC"] 652 | in 653 | let alpha = 654 | match alpha with 655 | | None -> [] 656 | | Some false -> [] 657 | | Some true -> ["ALPHA"] 658 | in 659 | let store = 660 | match store with 661 | | None -> [] 662 | | Some destination -> ["STORE"; destination] 663 | in 664 | let q = [["SORT"; key]; by; limit; get; order; alpha; store] |> List.concat in 665 | match%bind request t q with 666 | | Resp.Integer count -> return @@ `Count count 667 | | Resp.Array sorted -> 668 | sorted 669 | |> List.map ~f:(function 670 | | Resp.Bulk v -> Ok v 671 | | _ -> Error `Unexpected) 672 | |> Result.all 673 | |> Result.map ~f:(fun x -> `Sorted x) 674 | |> Deferred.return 675 | | _ -> Deferred.return @@ Error `Unexpected 676 | 677 | let ttl t key = 678 | let open Deferred.Result.Let_syntax in 679 | match%bind request t ["PTTL"; key] with 680 | | Resp.Integer -2 -> Deferred.return @@ Error (`No_such_key key) 681 | | Resp.Integer -1 -> Deferred.return @@ Error (`Not_expiring key) 682 | | Resp.Integer ms -> ms |> float_of_int |> Time.Span.of_ms |> return 683 | | _ -> Deferred.return @@ Error `Unexpected 684 | 685 | let type' t key = 686 | let open Deferred.Result.Let_syntax in 687 | match%bind request t ["TYPE"; key] with 688 | | Resp.String "none" -> return None 689 | | Resp.String s -> return @@ Some s 690 | | _ -> Deferred.return @@ Error `Unexpected 691 | 692 | let dump t key = 693 | let open Deferred.Result.Let_syntax in 694 | match%bind request t ["DUMP"; key] with 695 | | Resp.Bulk bulk -> return @@ Some bulk 696 | | Resp.Null -> return None 697 | | _ -> Deferred.return @@ Error `Unexpected 698 | 699 | let restore t ~key ?ttl ?replace value = 700 | let open Deferred.Result.Let_syntax in 701 | let ttl = 702 | match ttl with 703 | | None -> "0" 704 | | Some span -> span |> Time.Span.to_ms |> Printf.sprintf ".0%f" 705 | in 706 | let replace = 707 | match replace with 708 | | Some true -> ["REPLACE"] 709 | | Some false | None -> [] 710 | in 711 | match%bind request t (["RESTORE"; key; ttl; value] @ replace) with 712 | | Resp.String "OK" -> return () 713 | | _ -> Deferred.return @@ Error `Unexpected 714 | 715 | let lindex t key index = 716 | let open Deferred.Result.Let_syntax in 717 | match%bind request t ["LINDEX"; key; string_of_int index] with 718 | | Resp.Bulk v -> return @@ Some v 719 | | Resp.Null -> return None 720 | | _ -> Deferred.return @@ Error `Unexpected 721 | 722 | type position = 723 | | Before 724 | | After 725 | 726 | let string_of_position = function 727 | | Before -> "BEFORE" 728 | | After -> "AFTER" 729 | 730 | let linsert t ~key position ~element ~pivot = 731 | let open Deferred.Result.Let_syntax in 732 | match%bind request t ["LINSERT"; key; string_of_position position; pivot; element] with 733 | | Resp.Integer n -> return n 734 | | _ -> Deferred.return @@ Error `Unexpected 735 | 736 | let llen t key = 737 | let open Deferred.Result.Let_syntax in 738 | match%bind request t ["LLEN"; key] with 739 | | Resp.Integer n -> return n 740 | | _ -> Deferred.return @@ Error `Unexpected 741 | 742 | let omnidirectional_pop command t key = 743 | let open Deferred.Result.Let_syntax in 744 | match%bind request t [command; key] with 745 | | Resp.Bulk s -> return @@ Some s 746 | | Resp.Null -> return None 747 | | Resp.Error e when is_wrong_type e -> Deferred.return (Error (`Wrong_type key)) 748 | | _ -> Deferred.return @@ Error `Unexpected 749 | 750 | let rpop = omnidirectional_pop "RPOP" 751 | 752 | let lpop = omnidirectional_pop "LPOP" 753 | 754 | let hset t ~element ?(elements = []) key = 755 | let open Deferred.Result.Let_syntax in 756 | let field_values = 757 | element :: elements |> List.map ~f:(fun (f, v) -> [f; v]) |> List.concat 758 | in 759 | match%bind request t (["HSET"; key] @ field_values) with 760 | | Resp.Integer n -> return n 761 | | _ -> Deferred.return @@ Error `Unexpected 762 | 763 | let hget t ~field key = 764 | let open Deferred.Result.Let_syntax in 765 | match%bind request t ["HGET"; key; field] with 766 | | Resp.Bulk v -> return v 767 | | _ -> Deferred.return @@ Error `Unexpected 768 | 769 | let hmget t ~fields key = 770 | let open Deferred.Result.Let_syntax in 771 | match%bind request t (["HMGET"; key] @ fields) with 772 | | Resp.Array xs -> ( 773 | let unpacked = 774 | List.map2 fields xs ~f:(fun field -> 775 | function 776 | | Resp.Bulk v -> Ok (field, Some v) 777 | | Resp.Null -> Ok (field, None) 778 | | _ -> Error `Unexpected) 779 | in 780 | match unpacked with 781 | | Ok matching -> ( 782 | let%bind all_bindings = Deferred.return @@ Result.all matching in 783 | let bound_bindings = 784 | List.filter_map all_bindings ~f:(fun (k, v) -> 785 | match v with 786 | | Some v -> Some (k, v) 787 | | None -> None) 788 | in 789 | match String.Map.of_alist bound_bindings with 790 | | `Ok t -> return t 791 | | `Duplicate_key _ -> Deferred.return @@ Error `Unexpected) 792 | | Unequal_lengths -> Deferred.return @@ Error `Unexpected) 793 | | _ -> Deferred.return @@ Error `Unexpected 794 | 795 | let hgetall t key = 796 | let open Deferred.Result.Let_syntax in 797 | match%bind request t ["HGETALL"; key] with 798 | | Resp.Array xs -> ( 799 | let kvs = 800 | xs 801 | |> List.chunks_of ~length:2 802 | |> List.map ~f:(function 803 | | [Resp.Bulk key; Resp.Bulk value] -> Ok (key, value) 804 | | _ -> Error `Unexpected) 805 | |> Result.all 806 | in 807 | let%bind kvs = Deferred.return kvs in 808 | match String.Map.of_alist kvs with 809 | | `Ok t -> return t 810 | | `Duplicate_key _ -> Deferred.return @@ Error `Unexpected) 811 | | _ -> Deferred.return @@ Error `Unexpected 812 | 813 | let hdel t ?(fields = []) ~field key = 814 | let open Deferred.Result.Let_syntax in 815 | match%bind request t (["HDEL"; key; field] @ fields) with 816 | | Resp.Integer n -> return n 817 | | _ -> Deferred.return @@ Error `Unexpected 818 | 819 | let hexists t ~field key = 820 | let open Deferred.Result.Let_syntax in 821 | match%bind request t ["HEXISTS"; key; field] with 822 | | Resp.Integer 1 -> return true 823 | | Resp.Integer 0 -> return false 824 | | _ -> Deferred.return @@ Error `Unexpected 825 | 826 | let hincrby t ~field key increment = 827 | let open Deferred.Result.Let_syntax in 828 | match%bind request t ["HINCRBY"; key; field; string_of_int increment] with 829 | | Resp.Integer n -> return n 830 | | _ -> Deferred.return @@ Error `Unexpected 831 | 832 | let hincrbyfloat t ~field key increment = 833 | let open Deferred.Result.Let_syntax in 834 | match%bind request t ["HINCRBYFLOAT"; key; field; string_of_float increment] with 835 | | Resp.Bulk fl -> return @@ float_of_string fl 836 | | _ -> Deferred.return @@ Error `Unexpected 837 | 838 | let generic_keyvals command t key = 839 | let open Deferred.Result.Let_syntax in 840 | match%bind request t [command; key] with 841 | | Resp.Array xs -> 842 | let keys = 843 | List.map xs ~f:(function 844 | | Resp.Bulk x -> Ok x 845 | | _ -> Error `Unexpected) 846 | in 847 | Deferred.return @@ Result.all keys 848 | | _ -> Deferred.return @@ Error `Unexpected 849 | 850 | let hkeys = generic_keyvals "HKEYS" 851 | 852 | let hvals = generic_keyvals "HVALS" 853 | 854 | let hlen t key = 855 | let open Deferred.Result.Let_syntax in 856 | match%bind request t ["HLEN"; key] with 857 | | Resp.Integer n -> return n 858 | | _ -> Deferred.return @@ Error `Unexpected 859 | 860 | let hstrlen t ~field key = 861 | let open Deferred.Result.Let_syntax in 862 | match%bind request t ["HSTRLEN"; key; field] with 863 | | Resp.Integer n -> return n 864 | | _ -> Deferred.return @@ Error `Unexpected 865 | 866 | let publish t ~channel message = 867 | let open Deferred.Result.Let_syntax in 868 | match%bind request t ["PUBLISH"; channel; message] with 869 | | Resp.Integer n -> return n 870 | | _ -> Deferred.return @@ Error `Unexpected 871 | 872 | let with_connection ?(port = 6379) ~host f = 873 | let where = Tcp.Where_to_connect.of_host_and_port @@ Host_and_port.create ~host ~port in 874 | Tcp.with_connection where @@ fun _socket reader writer -> 875 | let t = init reader writer in 876 | f t 877 | -------------------------------------------------------------------------------- /test/integration/test.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Async 3 | 4 | (* This integration test will leak Redis keys left and right *) 5 | 6 | let host = "localhost" 7 | 8 | let exceeding_read_buffer = 128 * 1024 9 | 10 | module Orewa_error = struct 11 | type t = 12 | [ Orewa.common_error 13 | | `Redis_error of string 14 | | `No_such_key of string 15 | | `Not_expiring of string 16 | | `Wrong_type of string 17 | | `Index_out_of_range of string ] 18 | [@@deriving show, eq] 19 | end 20 | 21 | let err = Alcotest.testable Orewa_error.pp Orewa_error.equal 22 | 23 | let ue = Alcotest.(result unit err) 24 | 25 | let be = Alcotest.(result bool err) 26 | 27 | let ie = Alcotest.(result int err) 28 | 29 | let fe = Alcotest.(result (float 0.01) err) 30 | 31 | let se = Alcotest.(result string err) 32 | 33 | let sle = Alcotest.(result (list string) err) 34 | 35 | let soe = Alcotest.(result (option string) err) 36 | 37 | let some_string = Alcotest.testable String.pp (const (const true)) 38 | 39 | let bit = Alcotest.testable Orewa.pp_bit Orewa.equal_bit 40 | 41 | let colon ppf _ = Fmt.pf ppf ":@, " 42 | 43 | let dump_string ppf s = Fmt.pf ppf "%S" s 44 | 45 | let pp_binding = Fmt.(pair ~sep:colon dump_string dump_string) 46 | 47 | let smap_iter f m = String.Map.iteri m ~f:(fun ~key ~data -> f key data) 48 | 49 | let string_string_map_pp = Fmt.(braces (iter_bindings ~sep:comma smap_iter pp_binding)) 50 | 51 | let sm = Alcotest.testable string_string_map_pp (String.Map.equal String.equal) 52 | 53 | let sme = Alcotest.(result sm err) 54 | 55 | let unordered_string_list = 56 | Alcotest.( 57 | testable 58 | (pp (list string)) 59 | (fun a b -> 60 | let equal = equal (list string) in 61 | let compare = String.compare in 62 | equal (List.sort ~compare a) (List.sort ~compare b))) 63 | 64 | type string_pair = string * string [@@deriving ord] 65 | 66 | let unordered_string_tuple_list = 67 | Alcotest.( 68 | testable 69 | (pp (list (pair string string))) 70 | (fun a b -> 71 | let equal = equal (list (pair string string)) in 72 | equal 73 | (List.sort ~compare:compare_string_pair a) 74 | (List.sort ~compare:compare_string_pair b))) 75 | 76 | let truncated_string_pp formatter str = 77 | let str = Printf.sprintf "%s(...)" (String.prefix str 10) in 78 | Format.pp_print_text formatter str 79 | 80 | let truncated_string = Alcotest.testable truncated_string_pp String.equal 81 | 82 | let random_state = Random.State.make_self_init () 83 | 84 | let random_key () = 85 | let alphanumeric_char _ = 86 | let num = List.range ~stop:`inclusive 48 57 in 87 | let upper = List.range ~stop:`inclusive 65 90 in 88 | let lower = List.range ~stop:`inclusive 97 122 in 89 | let alnum = num @ upper @ lower in 90 | let random_int = List.random_element_exn ~random_state alnum in 91 | Char.of_int_exn random_int 92 | in 93 | let random_string = String.init 7 ~f:alphanumeric_char in 94 | Printf.sprintf "redis-integration-%s" random_string 95 | 96 | let test_echo () = 97 | Orewa.with_connection ~host @@ fun conn -> 98 | let message = "Hello" in 99 | let%bind response = Orewa.echo conn message in 100 | Alcotest.(check se) "ECHO faulty" (Ok message) response; 101 | return () 102 | 103 | let test_set () = 104 | Orewa.with_connection ~host @@ fun conn -> 105 | let key = random_key () in 106 | let%bind res = Orewa.set conn ~key "value" in 107 | Alcotest.(check be) "Successfully SET" (Ok true) res; 108 | let%bind res = Orewa.set conn ~key ~exist:`Not_if_exists "other" in 109 | Alcotest.(check be) "Didn't SET again" (Ok false) res; 110 | let%bind res = Orewa.set conn ~key ~exist:`Only_if_exists "other" in 111 | Alcotest.(check be) "Successfully re-SET" (Ok true) res; 112 | let not_existing = random_key () in 113 | let%bind res = Orewa.set conn ~key:not_existing ~exist:`Only_if_exists "value" in 114 | Alcotest.(check be) "Didn't SET non-existing" (Ok false) res; 115 | return () 116 | 117 | let test_get () = 118 | Orewa.with_connection ~host @@ fun conn -> 119 | let key = random_key () in 120 | let value = random_key () in 121 | let%bind _ = Orewa.set conn ~key value in 122 | let%bind res = Orewa.get conn key in 123 | Alcotest.(check soe) "Correct response" (Ok (Some value)) res; 124 | return () 125 | 126 | let test_getset () = 127 | Orewa.with_connection ~host @@ fun conn -> 128 | let key = random_key () in 129 | let value = random_key () in 130 | let value' = random_key () in 131 | let%bind res = Orewa.getset conn ~key value in 132 | Alcotest.(check soe) "Setting non-existing key returns no previous value" (Ok None) res; 133 | let%bind res = Orewa.getset conn ~key value' in 134 | Alcotest.(check soe) "Setting existing key returns previous value" (Ok (Some value)) res; 135 | return () 136 | 137 | let test_strlen () = 138 | Orewa.with_connection ~host @@ fun conn -> 139 | let key = random_key () in 140 | let value = random_key () in 141 | let%bind res = Orewa.strlen conn key in 142 | Alcotest.(check ie) "Length of empty key is zero" (Ok 0) res; 143 | let%bind _ = Orewa.set conn ~key value in 144 | let%bind res = Orewa.strlen conn key in 145 | Alcotest.(check ie) 146 | "Length of key is determined correctly" 147 | (Ok (String.length value)) 148 | res; 149 | return () 150 | 151 | let test_mget () = 152 | Orewa.with_connection ~host @@ fun conn -> 153 | let key = random_key () in 154 | let non_existing_key = random_key () in 155 | let value = random_key () in 156 | let%bind _ = Orewa.set conn ~key value in 157 | let%bind res = Orewa.mget conn [non_existing_key; key; key] in 158 | Alcotest.(check (result (list (option string)) err)) 159 | "Correct response" 160 | (Ok [None; Some value; Some value]) 161 | res; 162 | return () 163 | 164 | let test_msetnx () = 165 | Orewa.with_connection ~host @@ fun conn -> 166 | let key = random_key () in 167 | let value = random_key () in 168 | let key' = random_key () in 169 | let value' = random_key () in 170 | let key'' = random_key () in 171 | let value'' = random_key () in 172 | let be = Alcotest.(result bool err) in 173 | let%bind res = Orewa.msetnx conn [key, value; key', value'] in 174 | Alcotest.(check be) "Setting once succeeded" (Ok true) res; 175 | let%bind res = Orewa.mget conn [key; key'] in 176 | Alcotest.(check (result (list (option string)) err)) 177 | "Keys as expected" 178 | (Ok [Some value; Some value']) 179 | res; 180 | let%bind res = Orewa.msetnx conn [key', value''; key'', value''] in 181 | Alcotest.(check be) "Setting once succeeded" (Ok false) res; 182 | let%bind res = Orewa.mget conn [key; key'; key''] in 183 | Alcotest.(check (result (list (option string)) err)) 184 | "Keys as expected" 185 | (Ok [Some value; Some value'; None]) 186 | res; 187 | return () 188 | 189 | let test_mset () = 190 | Orewa.with_connection ~host @@ fun conn -> 191 | let key = random_key () in 192 | let value = random_key () in 193 | let key' = random_key () in 194 | let value' = random_key () in 195 | let%bind res = Orewa.mset conn [key, value; key', value'] in 196 | Alcotest.(check ue) "Correct response" (Ok ()) res; 197 | let%bind res = Orewa.mget conn [key; key'] in 198 | Alcotest.(check (result (list (option string)) err)) 199 | "Correct response" 200 | (Ok [Some value; Some value']) 201 | res; 202 | return () 203 | 204 | let test_getrange () = 205 | Orewa.with_connection ~host @@ fun conn -> 206 | let key = random_key () in 207 | let not_existing_key = random_key () in 208 | let value = "Hello" in 209 | let%bind _ = Orewa.set conn ~key value in 210 | let%bind res = Orewa.getrange conn key ~start:1 ~end':3 in 211 | Alcotest.(check se) "Correct response" (Ok "ell") res; 212 | let%bind res = Orewa.getrange conn not_existing_key ~start:1 ~end':3 in 213 | Alcotest.(check se) "Correct response" (Ok "") res; 214 | return () 215 | 216 | let test_set_expiry () = 217 | Orewa.with_connection ~host @@ fun conn -> 218 | let key = random_key () in 219 | let value = random_key () in 220 | let expire = Time.Span.of_ms 200. in 221 | let%bind res = Orewa.set conn ~key ~expire value in 222 | Alcotest.(check be) "Correctly SET expiry" (Ok true) res; 223 | let%bind res = Orewa.get conn key in 224 | Alcotest.(check soe) "Key still exists" (Ok (Some value)) res; 225 | let%bind () = after Time.Span.(expire / 0.75) in 226 | let%bind res = Orewa.get conn key in 227 | Alcotest.(check soe) "Key has expired" (Ok None) res; 228 | return () 229 | 230 | let test_large_set_get () = 231 | Orewa.with_connection ~host @@ fun conn -> 232 | let key = random_key () in 233 | let value = String.init exceeding_read_buffer ~f:(fun _ -> 'a') in 234 | let%bind res = Orewa.set conn ~key value in 235 | Alcotest.(check be) "Large SET failed" (Ok true) res; 236 | let%bind res = Orewa.get conn key in 237 | Alcotest.(check soe) "Large GET retrieves everything" (Ok (Some value)) res; 238 | return () 239 | 240 | let test_lpush () = 241 | Orewa.with_connection ~host @@ fun conn -> 242 | let key = random_key () in 243 | let not_list = random_key () in 244 | let element = "value" in 245 | let%bind res = Orewa.lpush conn ~exist:`Only_if_exists ~element key in 246 | Alcotest.(check ie) "LPUSHX to non-existing list" (Ok 0) res; 247 | let%bind res = Orewa.lpush conn ~element key in 248 | Alcotest.(check ie) "LPUSH to empty list" (Ok 1) res; 249 | let%bind res = Orewa.lpush conn ~exist:`Always ~element key in 250 | Alcotest.(check ie) "LPUSH to existing list" (Ok 2) res; 251 | let%bind _ = Orewa.set conn ~key:not_list element in 252 | let%bind res = Orewa.lpush conn ~element not_list in 253 | Alcotest.(check ie) "LPUSH to not a list" (Error (`Wrong_type not_list)) res; 254 | return () 255 | 256 | let test_rpush () = 257 | Orewa.with_connection ~host @@ fun conn -> 258 | let key = random_key () in 259 | let not_list = random_key () in 260 | let element = "value" in 261 | let%bind res = Orewa.rpush conn ~exist:`Only_if_exists ~element key in 262 | Alcotest.(check ie) "RPUSHX to non-existing list" (Ok 0) res; 263 | let%bind res = Orewa.rpush conn ~element key in 264 | Alcotest.(check ie) "RPUSH to empty list" (Ok 1) res; 265 | let%bind res = Orewa.rpush conn ~exist:`Always ~element key in 266 | Alcotest.(check ie) "RPUSH to existing list" (Ok 2) res; 267 | let%bind _ = Orewa.set conn ~key:not_list element in 268 | let%bind res = Orewa.rpush conn ~element not_list in 269 | Alcotest.(check ie) "RPUSH to not a list" (Error (`Wrong_type not_list)) res; 270 | return () 271 | 272 | let test_lpush_lrange () = 273 | Orewa.with_connection ~host @@ fun conn -> 274 | let key = random_key () in 275 | let element = random_key () in 276 | let element' = random_key () in 277 | let%bind _ = Orewa.lpush conn ~element key in 278 | let%bind _ = Orewa.lpush conn ~element:element' key in 279 | let%bind res = Orewa.lrange conn ~key ~start:0 ~stop:(-1) in 280 | Alcotest.(check (result (list truncated_string) err)) 281 | "LRANGE failed" 282 | (Ok [element'; element]) 283 | res; 284 | return () 285 | 286 | let test_large_lrange () = 287 | Orewa.with_connection ~host @@ fun conn -> 288 | let key = random_key () in 289 | let element = String.init exceeding_read_buffer ~f:(fun _ -> 'a') in 290 | let values = 5 in 291 | let%bind expected = 292 | Deferred.List.init values ~f:(fun _ -> 293 | let%bind _ = Orewa.lpush conn ~element key in 294 | return element) 295 | in 296 | let%bind res = Orewa.lrange conn ~key ~start:0 ~stop:(-1) in 297 | Alcotest.(check (result (list truncated_string) err)) "LRANGE failed" (Ok expected) res; 298 | return () 299 | 300 | let test_rpoplpush () = 301 | Orewa.with_connection ~host @@ fun conn -> 302 | let source = random_key () in 303 | let destination = random_key () in 304 | let element = "three" in 305 | let not_list = random_key () in 306 | let%bind _ = Orewa.rpush conn source ~element:"one" in 307 | let%bind _ = Orewa.rpush conn source ~element:"two" in 308 | let%bind _ = Orewa.rpush conn source ~element in 309 | let%bind res = Orewa.rpoplpush conn ~source ~destination in 310 | Alcotest.(check se) "RPOPLPUSH moved the correct element" (Ok element) res; 311 | let%bind _ = Orewa.set conn ~key:not_list element in 312 | let%bind res = Orewa.rpoplpush conn ~source ~destination:not_list in 313 | let wrong_move_destination = Printf.sprintf "%s -> %s" source not_list in 314 | Alcotest.(check se) 315 | "RPOPLPUSH failed to move to non-list" 316 | (Error (`Wrong_type wrong_move_destination)) 317 | res; 318 | let%bind res = Orewa.rpoplpush conn ~source:not_list ~destination in 319 | let wrong_move_source = Printf.sprintf "%s -> %s" not_list destination in 320 | Alcotest.(check se) 321 | "RPOPLPUSH failed to move from non-list" 322 | (Error (`Wrong_type wrong_move_source)) 323 | res; 324 | return () 325 | 326 | let test_append () = 327 | Orewa.with_connection ~host @@ fun conn -> 328 | let key = random_key () in 329 | let value = random_key () in 330 | let%bind res = Orewa.append conn ~key value in 331 | Alcotest.(check (result int err)) "APPEND unexpected" (Ok (String.length value)) res; 332 | return () 333 | 334 | let test_auth () = 335 | Orewa.with_connection ~host @@ fun conn -> 336 | let password = random_key () in 337 | let%bind res = Orewa.auth conn password in 338 | let expected = Error (`Redis_error "ERR Client sent AUTH, but no password is set") in 339 | Alcotest.(check (result unit err)) "AUTH failed" expected res; 340 | return () 341 | 342 | let test_bgrewriteaof () = 343 | Orewa.with_connection ~host @@ fun conn -> 344 | let%bind res = Orewa.bgrewriteaof conn in 345 | let expected = Ok "blurb" in 346 | Alcotest.(check (result some_string err)) "BGREWRITEAOF failed" expected res; 347 | let%bind _ = Deferred.ok @@ after (Time.Span.of_sec 1.) in 348 | return () 349 | 350 | let test_bgsave () = 351 | Orewa.with_connection ~host @@ fun conn -> 352 | let%bind res = Orewa.bgsave conn in 353 | let expected = Ok "blurb" in 354 | Alcotest.(check (result some_string err)) "BGSAVE failed" expected res; 355 | return () 356 | 357 | let test_bitcount () = 358 | Orewa.with_connection ~host @@ fun conn -> 359 | let key = random_key () in 360 | let%bind _ = Orewa.set conn ~key "aaaa" in 361 | let%bind res = Orewa.bitcount conn key in 362 | Alcotest.(check (result int err)) "BITCOUNT failed" (Ok 12) res; 363 | let%bind res = Orewa.bitcount conn ~range:(1, 2) key in 364 | Alcotest.(check (result int err)) "BITCOUNT failed" (Ok 6) res; 365 | return () 366 | 367 | let test_bitop () = 368 | Orewa.with_connection ~host @@ fun conn -> 369 | let key = random_key () in 370 | let destkey = random_key () in 371 | let value = "aaaa" in 372 | let expected = Ok (String.length value) in 373 | let%bind _ = Orewa.set conn ~key value in 374 | let%bind res = Orewa.bitop conn ~destkey ~keys:[key] ~key Orewa.AND in 375 | Alcotest.(check (result int err)) "BITOP failed" expected res; 376 | let%bind res = Orewa.bitop conn ~destkey ~keys:[key] ~key Orewa.XOR in 377 | Alcotest.(check (result int err)) "BITOP failed" expected res; 378 | return () 379 | 380 | let test_bitpos () = 381 | Orewa.with_connection ~host @@ fun conn -> 382 | let key = random_key () in 383 | let value = "\000\001\000\000\001" in 384 | let expected = Ok (Some 15) in 385 | let%bind _ = Orewa.set conn ~key value in 386 | let%bind res = Orewa.bitpos conn key One in 387 | Alcotest.(check (result (option int) err)) "BITPOS failed" expected res; 388 | let%bind res = Orewa.bitpos conn ~start:2 key One in 389 | let expected = Ok (Some 39) in 390 | Alcotest.(check (result (option int) err)) "BITPOS failed" expected res; 391 | let%bind res = Orewa.bitpos conn ~start:2 ~end':3 key One in 392 | let expected = Ok None in 393 | Alcotest.(check (result (option int) err)) "BITPOS failed" expected res; 394 | return () 395 | 396 | let test_getbit () = 397 | Orewa.with_connection ~host @@ fun conn -> 398 | let key = random_key () in 399 | let value = "\001" in 400 | let%bind _ = Orewa.set conn ~key value in 401 | let expected = Ok Orewa.Zero in 402 | let%bind res = Orewa.getbit conn key 0 in 403 | Alcotest.(check (result bit err)) "GETBIT failed" expected res; 404 | let expected = Ok Orewa.Zero in 405 | let%bind res = Orewa.getbit conn key 8 in 406 | Alcotest.(check (result bit err)) "GETBIT failed" expected res; 407 | return () 408 | 409 | let test_setbit () = 410 | Orewa.with_connection ~host @@ fun conn -> 411 | let key = random_key () in 412 | let offset = 10 in 413 | let%bind res = Orewa.setbit conn key offset Orewa.One in 414 | Alcotest.(check (result bit err)) "SETBIT failed" (Ok Orewa.Zero) res; 415 | let%bind res = Orewa.setbit conn key offset Orewa.Zero in 416 | Alcotest.(check (result bit err)) "SETBIT failed" (Ok Orewa.One) res; 417 | return () 418 | 419 | let test_bitfield () = 420 | Orewa.with_connection ~host @@ fun conn -> 421 | let key = random_key () in 422 | let ile = Alcotest.(result (list (option int)) err) in 423 | let intsize = Orewa.Unsigned 8 in 424 | let maxsize = 255 in 425 | let%bind res = Orewa.bitfield conn key [Set (intsize, Absolute 0, 1)] in 426 | Alcotest.(check ile) "Setting returns previous value" (Ok [Some 0]) res; 427 | let%bind res = Orewa.bitfield conn key [Set (intsize, Absolute 0, 0)] in 428 | Alcotest.(check ile) "Setting returns previous value" (Ok [Some 1]) res; 429 | let%bind res = Orewa.bitfield conn key [Get (intsize, Absolute 0)] in 430 | Alcotest.(check ile) "Getting returns current value" (Ok [Some 0]) res; 431 | let overflow_by = 42 in 432 | let%bind res = 433 | Orewa.bitfield 434 | conn 435 | key 436 | ~overflow:Orewa.Wrap 437 | [ Set (intsize, Relative 0, maxsize); 438 | Incrby (intsize, Relative 0, Int.succ overflow_by) ] 439 | in 440 | Alcotest.(check ile) 441 | "Relative setting and overflow work" 442 | (Ok [Some 0; Some overflow_by]) 443 | res; 444 | let%bind res = 445 | Orewa.bitfield 446 | conn 447 | key 448 | ~overflow:Orewa.Sat 449 | [Set (intsize, Relative 0, maxsize); Incrby (intsize, Relative 0, 1)] 450 | in 451 | Alcotest.(check ile) 452 | "Saturated overflow works" 453 | (Ok [Some overflow_by; Some maxsize]) 454 | res; 455 | let%bind res = 456 | Orewa.bitfield conn key ~overflow:Orewa.Fail [Incrby (intsize, Relative 0, 1)] 457 | in 458 | Alcotest.(check ile) "Failing overflow works" (Ok [None]) res; 459 | return () 460 | 461 | let test_decr () = 462 | Orewa.with_connection ~host @@ fun conn -> 463 | let key = random_key () in 464 | let value = 42 in 465 | let%bind _ = Orewa.set conn ~key (string_of_int value) in 466 | let%bind res = Orewa.decr conn key in 467 | Alcotest.(check (result int err)) "DECR failed" (Ok (Int.pred value)) res; 468 | return () 469 | 470 | let test_decrby () = 471 | Orewa.with_connection ~host @@ fun conn -> 472 | let key = random_key () in 473 | let value = 42 in 474 | let decrement = 23 in 475 | let%bind _ = Orewa.set conn ~key (string_of_int value) in 476 | let%bind res = Orewa.decrby conn key decrement in 477 | Alcotest.(check (result int err)) "DECRBY failed" (Ok (value - decrement)) res; 478 | return () 479 | 480 | let test_incr () = 481 | Orewa.with_connection ~host @@ fun conn -> 482 | let key = random_key () in 483 | let value = 42 in 484 | let%bind _ = Orewa.set conn ~key (string_of_int value) in 485 | let%bind res = Orewa.incr conn key in 486 | Alcotest.(check (result int err)) "INCR failed" (Ok (Int.succ value)) res; 487 | return () 488 | 489 | let test_incrby () = 490 | Orewa.with_connection ~host @@ fun conn -> 491 | let key = random_key () in 492 | let value = 42 in 493 | let increment = 23 in 494 | let%bind _ = Orewa.set conn ~key (string_of_int value) in 495 | let%bind res = Orewa.incrby conn key increment in 496 | Alcotest.(check (result int err)) "INCRBY failed" (Ok (value + increment)) res; 497 | return () 498 | 499 | let test_incrbyfloat () = 500 | Orewa.with_connection ~host @@ fun conn -> 501 | let key = random_key () in 502 | let increment = 42. in 503 | let%bind res = Orewa.incrbyfloat conn key increment in 504 | Alcotest.(check (result (float 0.1) err)) "INCRBYFLOAT failed" (Ok increment) res; 505 | return () 506 | 507 | let test_select () = 508 | Orewa.with_connection ~host @@ fun conn -> 509 | let index = 5 in 510 | let%bind res = Orewa.select conn index in 511 | Alcotest.(check (result unit err)) "SELECT failed" (Ok ()) res; 512 | return () 513 | 514 | let test_del () = 515 | Orewa.with_connection ~host @@ fun conn -> 516 | let key = random_key () in 517 | let key' = random_key () in 518 | let value = "aaaa" in 519 | let%bind _ = Orewa.set conn ~key value in 520 | let%bind _ = Orewa.set conn ~key:key' value in 521 | let%bind res = Orewa.del conn ~keys:[key'] key in 522 | Alcotest.(check (result int err)) "DEL failed" (Ok 2) res; 523 | return () 524 | 525 | let test_exists () = 526 | Orewa.with_connection ~host @@ fun conn -> 527 | let existing = random_key () in 528 | let missing = random_key () in 529 | let value = "aaaa" in 530 | let%bind _ = Orewa.set conn ~key:existing value in 531 | let%bind res = Orewa.exists conn ~keys:[existing] missing in 532 | Alcotest.(check (result int err)) "EXISTS failed" (Ok 1) res; 533 | return () 534 | 535 | let test_expire () = 536 | Orewa.with_connection ~host @@ fun conn -> 537 | let key = random_key () in 538 | let value = "aaaa" in 539 | let expire = Time.Span.of_ms 200. in 540 | let%bind _ = Orewa.set conn ~key value in 541 | let%bind res = Orewa.expire conn key expire in 542 | Alcotest.(check (result int err)) "Correctly SET expiry" (Ok 1) res; 543 | let%bind res = Orewa.exists conn key in 544 | Alcotest.(check (result int err)) "Key still exists" (Ok 1) res; 545 | let%bind () = after Time.Span.(expire / 0.75) in 546 | let%bind res = Orewa.exists conn key in 547 | Alcotest.(check (result int err)) "Key has expired" (Ok 0) res; 548 | return () 549 | 550 | let test_expireat () = 551 | Orewa.with_connection ~host @@ fun conn -> 552 | let key = random_key () in 553 | let value = "aaaa" in 554 | let expire = Time.Span.of_ms 200. in 555 | let at = Time.add (Time.now ()) expire in 556 | let%bind _ = Orewa.set conn ~key value in 557 | let%bind res = Orewa.expireat conn key at in 558 | Alcotest.(check (result int err)) "Correctly SET expiry" (Ok 1) res; 559 | let%bind res = Orewa.exists conn key in 560 | Alcotest.(check (result int err)) "Key still exists" (Ok 1) res; 561 | let%bind () = after Time.Span.(expire / 0.75) in 562 | let%bind res = Orewa.exists conn key in 563 | Alcotest.(check (result int err)) "Key has expired" (Ok 0) res; 564 | return () 565 | 566 | let test_keys () = 567 | Orewa.with_connection ~host @@ fun conn -> 568 | let prefix = random_key () in 569 | let key1 = prefix ^ random_key () in 570 | let key2 = prefix ^ random_key () in 571 | let value = "aaaa" in 572 | let%bind _ = Orewa.set conn ~key:key1 value in 573 | let%bind _ = Orewa.set conn ~key:key2 value in 574 | let%bind res = Orewa.keys conn (prefix ^ "*") in 575 | Alcotest.(check (result unordered_string_list err)) 576 | "Returns the right keys" 577 | (Ok [key1; key2]) 578 | res; 579 | let none = random_key () in 580 | let%bind res = Orewa.keys conn (none ^ "*") in 581 | Alcotest.(check (result (list string) err)) "Returns no keys" (Ok []) res; 582 | return () 583 | 584 | let test_sadd () = 585 | Orewa.with_connection ~host @@ fun conn -> 586 | let key = random_key () in 587 | let zero = "0" in 588 | let dup = "dup" in 589 | let%bind res = Orewa.sadd conn ~key zero in 590 | Alcotest.(check (result int err)) "Inserts single value" (Ok 1) res; 591 | let%bind res = Orewa.sadd conn ~key "a" ~members:["b"; "c"] in 592 | Alcotest.(check (result int err)) "Inserts multiple values" (Ok 3) res; 593 | let%bind res = Orewa.sadd conn ~key zero in 594 | Alcotest.(check (result int err)) "Skips single duplicate value" (Ok 0) res; 595 | let%bind res = Orewa.sadd conn ~key dup ~members:[zero; dup] in 596 | Alcotest.(check (result int err)) "Skips multiple duplicate value" (Ok 1) res; 597 | return () 598 | 599 | let test_scard () = 600 | Orewa.with_connection ~host @@ fun conn -> 601 | let key = random_key () in 602 | let dup = "dup" in 603 | let%bind res = Orewa.scard conn key in 604 | Alcotest.(check (result int err)) "Nonexistant key is empty" (Ok 0) res; 605 | let%bind _ = Orewa.sadd conn ~key dup in 606 | let%bind res = Orewa.scard conn key in 607 | Alcotest.(check (result int err)) "Existent set has one member" (Ok 1) res; 608 | let%bind _ = Orewa.sadd conn ~key "a" ~members:["b"; "c"] in 609 | let%bind res = Orewa.scard conn key in 610 | Alcotest.(check (result int err)) "New set has even more members" (Ok 4) res; 611 | return () 612 | 613 | let test_sdiff () = 614 | Orewa.with_connection ~host @@ fun conn -> 615 | let key1 = random_key () in 616 | let key2 = random_key () in 617 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 618 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 619 | let%bind res = Orewa.sdiff conn key1 ~keys:[key2] in 620 | Alcotest.(check (result unordered_string_list err)) 621 | "Correct differing set" 622 | (Ok ["a"; "b"]) 623 | res; 624 | return () 625 | 626 | let test_sdiffstore () = 627 | Orewa.with_connection ~host @@ fun conn -> 628 | let key1 = random_key () in 629 | let key2 = random_key () in 630 | let destination = random_key () in 631 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 632 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 633 | let%bind res = Orewa.sdiffstore conn ~destination ~key:key1 ~keys:[key2] in 634 | Alcotest.(check (result int err)) "New set the right amount of members" (Ok 2) res; 635 | return () 636 | 637 | let test_sinter () = 638 | Orewa.with_connection ~host @@ fun conn -> 639 | let key1 = random_key () in 640 | let key2 = random_key () in 641 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 642 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 643 | let%bind res = Orewa.sinter conn key1 ~keys:[key2] in 644 | Alcotest.(check (result unordered_string_list err)) 645 | "Correct differing set" 646 | (Ok ["c"]) 647 | res; 648 | return () 649 | 650 | let test_sinterstore () = 651 | Orewa.with_connection ~host @@ fun conn -> 652 | let key1 = random_key () in 653 | let key2 = random_key () in 654 | let destination = random_key () in 655 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 656 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 657 | let%bind res = Orewa.sinterstore conn ~destination ~key:key1 ~keys:[key2] in 658 | Alcotest.(check (result int err)) 659 | "The right amount of members was calculated" 660 | (Ok 1) 661 | res; 662 | let%bind res = Orewa.scard conn destination in 663 | Alcotest.(check (result int err)) "The right members are in the new set" (Ok 1) res; 664 | return () 665 | 666 | let test_sismember () = 667 | Orewa.with_connection ~host @@ fun conn -> 668 | let key = random_key () in 669 | let member = "aaa" in 670 | let not_member = "bbb" in 671 | let%bind res = Orewa.sismember conn ~key member in 672 | Alcotest.(check (result bool err)) "Not member in inexistent set" (Ok false) res; 673 | let%bind _ = Orewa.sadd conn ~key member in 674 | let%bind res = Orewa.sismember conn ~key member in 675 | Alcotest.(check (result bool err)) "Member in set" (Ok true) res; 676 | let%bind res = Orewa.sismember conn ~key not_member in 677 | Alcotest.(check (result bool err)) "Not member in set" (Ok false) res; 678 | return () 679 | 680 | let test_smembers () = 681 | Orewa.with_connection ~host @@ fun conn -> 682 | let key = random_key () in 683 | let member = "aaa" in 684 | let%bind res = Orewa.smembers conn key in 685 | Alcotest.(check (result (list string) err)) "Not member in inexistent set" (Ok []) res; 686 | let%bind _ = Orewa.sadd conn ~key member in 687 | let%bind res = Orewa.smembers conn key in 688 | Alcotest.(check (result (list string) err)) "Members in existent set" (Ok [member]) res; 689 | return () 690 | 691 | let test_smove () = 692 | Orewa.with_connection ~host @@ fun conn -> 693 | let source = random_key () in 694 | let destination = random_key () in 695 | let member = "aaa" in 696 | let%bind res = Orewa.smove conn ~source ~destination member in 697 | Alcotest.(check (result bool err)) 698 | "Moving from a set where not member is noop" 699 | (Ok false) 700 | res; 701 | let%bind _ = Orewa.sadd conn ~key:source member in 702 | let%bind res = Orewa.smove conn ~source ~destination member in 703 | Alcotest.(check (result bool err)) "Moving from a set works" (Ok false) res; 704 | let%bind res = Orewa.sismember conn ~key:source member in 705 | Alcotest.(check (result bool err)) "Correctly removed from source" (Ok false) res; 706 | let%bind res = Orewa.sismember conn ~key:destination member in 707 | Alcotest.(check (result bool err)) "Correctly arrived in destination" (Ok true) res; 708 | return () 709 | 710 | let test_spop () = 711 | Orewa.with_connection ~host @@ fun conn -> 712 | let key = random_key () in 713 | let%bind res = Orewa.spop conn key in 714 | Alcotest.(check (result (list string) err)) "Popping from nonexistent set" (Ok []) res; 715 | let%bind _ = Orewa.sadd conn ~key "a" ~members:["b"; "c"] in 716 | let%bind res = Orewa.spop conn key in 717 | let length = Result.map ~f:List.length in 718 | Alcotest.(check (result int err)) "Popping one from existing set" (Ok 1) (length res); 719 | let count = 2 in 720 | let%bind res = Orewa.spop conn ~count key in 721 | Alcotest.(check (result int err)) 722 | "Popping rest from existing set" 723 | (Ok count) 724 | (length res); 725 | let%bind res = Orewa.scard conn key in 726 | Alcotest.(check (result int err)) "Set is empty now" (Ok 0) res; 727 | return () 728 | 729 | let test_srandmember () = 730 | Orewa.with_connection ~host @@ fun conn -> 731 | let key = random_key () in 732 | let%bind res = Orewa.srandmember conn key in 733 | Alcotest.(check (result (list string) err)) 734 | "Random element from nonexistent set" 735 | (Ok []) 736 | res; 737 | let%bind _ = Orewa.sadd conn ~key "a" ~members:["b"; "c"] in 738 | let%bind res = Orewa.srandmember conn key in 739 | let length = Result.map ~f:List.length in 740 | Alcotest.(check (result int err)) 741 | "One random member from existing set" 742 | (Ok 1) 743 | (length res); 744 | let count = 4 in 745 | let%bind res = Orewa.srandmember conn ~count key in 746 | Alcotest.(check (result int err)) 747 | "Getting all elements from existing set" 748 | (Ok 3) 749 | (length res); 750 | return () 751 | 752 | let test_srem () = 753 | Orewa.with_connection ~host @@ fun conn -> 754 | let key = random_key () in 755 | let members = ["b"; "c"; "d"] in 756 | let%bind _ = Orewa.sadd conn ~key "a" ~members in 757 | let%bind res = Orewa.srem conn ~key "a" in 758 | Alcotest.(check (result int err)) "Remove single member" (Ok 1) res; 759 | let%bind res = Orewa.srem conn ~key "a" ~members in 760 | Alcotest.(check (result int err)) "Remove remaining members" (Ok 3) res; 761 | let%bind res = Orewa.scard conn key in 762 | Alcotest.(check (result int err)) "Set is empty now" (Ok 0) res; 763 | return () 764 | 765 | let test_sunion () = 766 | Orewa.with_connection ~host @@ fun conn -> 767 | let key1 = random_key () in 768 | let key2 = random_key () in 769 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 770 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 771 | let%bind res = Orewa.sunion conn key1 ~keys:[key2] in 772 | Alcotest.(check (result unordered_string_list err)) 773 | "Correct differing set" 774 | (Ok ["a"; "b"; "c"; "d"; "e"]) 775 | res; 776 | return () 777 | 778 | let test_sunionstore () = 779 | Orewa.with_connection ~host @@ fun conn -> 780 | let key1 = random_key () in 781 | let key2 = random_key () in 782 | let destination = random_key () in 783 | let%bind _ = Orewa.sadd conn ~key:key1 "a" ~members:["b"; "c"] in 784 | let%bind _ = Orewa.sadd conn ~key:key2 "c" ~members:["d"; "e"] in 785 | let%bind res = Orewa.sunionstore conn ~destination ~key:key1 ~keys:[key2] in 786 | Alcotest.(check (result int err)) 787 | "The right amount of members was calculated" 788 | (Ok 5) 789 | res; 790 | let%bind res = Orewa.scard conn destination in 791 | Alcotest.(check (result int err)) "The right members are in the new set" (Ok 5) res; 792 | return () 793 | 794 | let test_sscan () = 795 | Orewa.with_connection ~host @@ fun conn -> 796 | let key = random_key () in 797 | let count = 20 in 798 | let members = 799 | List.init count ~f:(fun i -> String.concat ~sep:":" ["mem"; string_of_int i]) 800 | in 801 | let%bind _ = Orewa.sadd conn ~key "dummy" ~members in 802 | let pattern = "mem:*" in 803 | let pipe = Orewa.sscan conn ~pattern ~count:4 key in 804 | let%bind q = Pipe.read_all pipe in 805 | let res = Queue.to_list q in 806 | Alcotest.(check unordered_string_list) "Returns the right keys" members res; 807 | return () 808 | 809 | let test_scan () = 810 | Orewa.with_connection ~host @@ fun conn -> 811 | let prefix = random_key () in 812 | let value = "aaaa" in 813 | let count = 20 in 814 | let%bind expected_keys = 815 | Deferred.List.map (List.range 0 count) ~f:(fun index -> 816 | let key = Printf.sprintf "%s:%d" prefix index in 817 | let%bind _ = Orewa.set conn ~key value in 818 | return key) 819 | in 820 | let pattern = prefix ^ "*" in 821 | let pipe = Orewa.scan ~pattern ~count:4 conn in 822 | let%bind q = Pipe.read_all pipe in 823 | let res = Queue.to_list q in 824 | Alcotest.(check unordered_string_list) "Returns the right keys" expected_keys res; 825 | return () 826 | 827 | let test_move () = 828 | Orewa.with_connection ~host @@ fun conn -> 829 | let key = random_key () in 830 | let value = "aaaa" in 831 | let other_db = 4 in 832 | let original_db = 0 in 833 | let%bind _ = Orewa.select conn original_db in 834 | let%bind _ = Orewa.set conn ~key value in 835 | let%bind res = Orewa.move conn key other_db in 836 | Alcotest.(check (result bool err)) "Successfully moved" (Ok true) res; 837 | let%bind _ = Orewa.select conn other_db in 838 | let%bind res = Orewa.get conn key in 839 | Alcotest.(check soe) "Key in other db" (Ok (Some value)) res; 840 | let%bind _ = Orewa.select conn original_db in 841 | let%bind res = Orewa.move conn key other_db in 842 | Alcotest.(check (result bool err)) "MOVE failed as expected" (Ok false) res; 843 | return () 844 | 845 | let test_persist () = 846 | Orewa.with_connection ~host @@ fun conn -> 847 | let key = random_key () in 848 | let missing_key = random_key () in 849 | let value = "aaaa" in 850 | let%bind _ = Orewa.set conn ~expire:(Time.Span.of_sec 30.) ~key value in 851 | let%bind res = Orewa.persist conn key in 852 | Alcotest.(check (result bool err)) "Set key to persistent" (Ok true) res; 853 | let%bind res = Orewa.persist conn key in 854 | Alcotest.(check (result bool err)) "Key couldn't be persisted twice" (Ok false) res; 855 | let%bind res = Orewa.persist conn missing_key in 856 | Alcotest.(check (result bool err)) "Missing key couldn't be persisted" (Ok false) res; 857 | return () 858 | 859 | let test_randomkey () = 860 | Orewa.with_connection ~host @@ fun conn -> 861 | let key = random_key () in 862 | let value = "aaaa" in 863 | let%bind _ = Orewa.set conn ~key value in 864 | let%bind res = Orewa.randomkey conn in 865 | Alcotest.(check (result some_string err)) "Got random key" (Ok "anything") res; 866 | return () 867 | 868 | let test_rename () = 869 | Orewa.with_connection ~host @@ fun conn -> 870 | let key = random_key () in 871 | let new_key = random_key () in 872 | let value = "aaaa" in 873 | let%bind _ = Orewa.set conn ~key value in 874 | let%bind res = Orewa.rename conn key new_key in 875 | Alcotest.(check ue) "Successfully renamed" (Ok ()) res; 876 | let%bind res = Orewa.get conn new_key in 877 | Alcotest.(check soe) "Key exists in new location" (Ok (Some value)) res; 878 | let%bind res = Orewa.get conn key in 879 | Alcotest.(check soe) "Key gone in old location" (Ok None) res; 880 | return () 881 | 882 | let test_renamenx () = 883 | Orewa.with_connection ~host @@ fun conn -> 884 | let key = random_key () in 885 | let new_key = random_key () in 886 | let value = "aaaa" in 887 | let%bind _ = Orewa.set conn ~key value in 888 | let%bind res = Orewa.renamenx conn ~key new_key in 889 | Alcotest.(check (result bool err)) "Successfully renamed" (Ok true) res; 890 | let%bind _ = Orewa.set conn ~key value in 891 | let%bind res = Orewa.renamenx conn ~key new_key in 892 | Alcotest.(check (result bool err)) 893 | "Renaming to existing key shouldn't work" 894 | (Ok false) 895 | res; 896 | return () 897 | 898 | type sort_result = 899 | [ `Count of int 900 | | `Sorted of string list ] 901 | [@@deriving show, eq] 902 | 903 | let test_sort () = 904 | Orewa.with_connection ~host @@ fun conn -> 905 | let key = random_key () in 906 | let randomly_ordered = 907 | List.range 0 10 |> List.map ~f:(fun _ -> Random.State.int random_state 1000) 908 | in 909 | let%bind () = 910 | Deferred.List.iter randomly_ordered ~f:(fun value -> 911 | let%bind _ = Orewa.lpush conn ~element:(string_of_int value) key in 912 | return ()) 913 | in 914 | let%bind res = Orewa.sort conn key in 915 | let sort_result = Alcotest.testable pp_sort_result equal_sort_result in 916 | let integer_sorted = 917 | randomly_ordered |> List.sort ~compare:Int.compare |> List.map ~f:string_of_int 918 | in 919 | Alcotest.(check (result sort_result err)) 920 | "Sorted by integer value" 921 | (Ok (`Sorted integer_sorted)) 922 | res; 923 | let%bind res = Orewa.sort conn ~alpha:true key in 924 | let alpha_sorted = 925 | randomly_ordered |> List.map ~f:string_of_int |> List.sort ~compare:String.compare 926 | in 927 | Alcotest.(check (result sort_result err)) 928 | "Sorted alphabetically" 929 | (Ok (`Sorted alpha_sorted)) 930 | res; 931 | let store = random_key () in 932 | let%bind res = Orewa.sort conn ~store key in 933 | Alcotest.(check (result sort_result err)) 934 | "Sorted all elements" 935 | (Ok (`Count (List.length randomly_ordered))) 936 | res; 937 | let%bind res = Orewa.lrange conn ~key:store ~start:0 ~stop:(-1) in 938 | Alcotest.(check (result (list string) err)) 939 | "Sorted correctly in extra key" 940 | (Ok integer_sorted) 941 | res; 942 | return () 943 | 944 | let test_ttl () = 945 | Orewa.with_connection ~host @@ fun conn -> 946 | let key = random_key () in 947 | let missing_key = random_key () in 948 | let persistent_key = random_key () in 949 | let%bind res = Orewa.ttl conn missing_key in 950 | let span = Alcotest.testable Time.Span.pp Time.Span.equal in 951 | Alcotest.(check (result span err)) 952 | "No TTL on missing keys" 953 | (Error (`No_such_key missing_key)) 954 | res; 955 | let%bind _ = Orewa.set conn ~key:persistent_key "aaaa" in 956 | let%bind res = Orewa.ttl conn persistent_key in 957 | Alcotest.(check (result span err)) 958 | "No TTL on persistent key" 959 | (Error (`Not_expiring persistent_key)) 960 | res; 961 | let expire = Time.Span.of_ms 200. in 962 | let%bind _ = Orewa.set conn ~expire ~key "aaaa" in 963 | let subspan = 964 | Alcotest.testable Time.Span.pp (fun a b -> 965 | Time.Span.(a <= expire) && Time.Span.(b <= expire)) 966 | in 967 | let%bind res = Orewa.ttl conn key in 968 | Alcotest.(check (result subspan err)) "TTL not larger than before" (Ok expire) res; 969 | return () 970 | 971 | let test_type' () = 972 | Orewa.with_connection ~host @@ fun conn -> 973 | let string_key = random_key () in 974 | let list_key = random_key () in 975 | let missing_key = random_key () in 976 | let%bind _ = Orewa.set conn ~key:string_key "aaaa" in 977 | let%bind _ = Orewa.lpush conn ~element:"aaaa" list_key in 978 | let%bind res = Orewa.type' conn string_key in 979 | Alcotest.(check soe) "Finds string" (Ok (Some "string")) res; 980 | let%bind res = Orewa.type' conn list_key in 981 | Alcotest.(check soe) "Finds list" (Ok (Some "list")) res; 982 | let%bind res = Orewa.type' conn missing_key in 983 | Alcotest.(check soe) "No hits" (Ok None) res; 984 | return () 985 | 986 | let test_dump () = 987 | Orewa.with_connection ~host @@ fun conn -> 988 | let key = random_key () in 989 | let missing_key = random_key () in 990 | let%bind _ = Orewa.set conn ~key "aaaa" in 991 | let%bind res = Orewa.dump conn key in 992 | let dump_result = Alcotest.(result (option some_string) err) in 993 | Alcotest.(check dump_result) "Dumping string key" (Ok (Some "anything")) res; 994 | let%bind res = Orewa.dump conn missing_key in 995 | Alcotest.(check dump_result) "Dumping missing key" (Ok None) res; 996 | return () 997 | 998 | let test_restore () = 999 | Orewa.with_connection ~host @@ fun conn -> 1000 | let key = random_key () in 1001 | let list_key = random_key () in 1002 | let new_key = random_key () in 1003 | let element = random_key () in 1004 | let%bind _ = Orewa.set conn ~key element in 1005 | let%bind res = Orewa.dump conn key in 1006 | let dumped = Option.value_exn (Option.value_exn (Result.ok res)) in 1007 | let%bind res = Orewa.restore conn ~key:new_key dumped in 1008 | Alcotest.(check ue) "Restoring key" (Ok ()) res; 1009 | let%bind res = Orewa.get conn new_key in 1010 | Alcotest.(check soe) "Correct value restored" (Ok (Some element)) res; 1011 | let%bind _ = Orewa.lpush conn ~element list_key in 1012 | let%bind res = Orewa.dump conn list_key in 1013 | let dumped = Option.value_exn (Option.value_exn (Result.ok res)) in 1014 | let%bind res = Orewa.restore conn ~key:new_key ~replace:true dumped in 1015 | Alcotest.(check ue) "Restoring key" (Ok ()) res; 1016 | let%bind res = Orewa.lrange conn ~key:new_key ~start:0 ~stop:(-1) in 1017 | Alcotest.(check (result (list string) err)) "Correct value restored" (Ok [element]) res; 1018 | return () 1019 | 1020 | let test_pipelining () = 1021 | Orewa.with_connection ~host @@ fun conn -> 1022 | (* Test that we in parallel can do multiple requests *) 1023 | let prefix = random_key () in 1024 | let key i = Printf.sprintf "%s.%d" prefix i in 1025 | let keys = Array.init 1000 ~f:key in 1026 | (* Now insert all the keys *) 1027 | let%bind () = 1028 | Deferred.Array.iteri ~how:`Sequential keys ~f:(fun i key -> 1029 | let%bind res = Orewa.set conn ~key (string_of_int i) in 1030 | Alcotest.(check be) "Set test key" (Ok true) res; 1031 | return ()) 1032 | in 1033 | let%bind () = 1034 | Deferred.Array.iteri 1035 | ~how:`Parallel 1036 | ~f:(fun i key -> 1037 | let%bind res = Orewa.get conn key in 1038 | Alcotest.(check soe) "Wrong value for key" (Ok (Some (string_of_int i))) res; 1039 | return ()) 1040 | keys 1041 | in 1042 | return () 1043 | 1044 | let test_close () = 1045 | let%bind conn = Orewa.connect ?port:None ~host in 1046 | let key = random_key () in 1047 | let%bind res = Orewa.set conn ~key "test" in 1048 | Alcotest.(check be) "Set test key" (Ok true) res; 1049 | let%bind res = Orewa.get conn key in 1050 | Alcotest.(check soe) "Get test key" (Ok (Some "test")) res; 1051 | let%bind () = Orewa.close conn in 1052 | let%bind res = Orewa.get conn key in 1053 | Alcotest.(check soe) "Get test key" (Error `Connection_closed) res; 1054 | return () 1055 | 1056 | let test_lindex () = 1057 | Orewa.with_connection ~host @@ fun conn -> 1058 | let key = random_key () in 1059 | let element = random_key () in 1060 | let%bind res = Orewa.lindex conn key 0 in 1061 | Alcotest.(check soe) "Get element out of empty list" (Ok None) res; 1062 | let not_list = random_key () in 1063 | let%bind _ = Orewa.set conn ~key:not_list "this is not a list" in 1064 | let%bind res = Orewa.lindex conn key 0 in 1065 | Alcotest.(check soe) "Get first element of not a list" (Ok None) res; 1066 | let%bind _ = Orewa.lpush conn ~element key in 1067 | let%bind _ = Orewa.lpush conn ~element:(random_key ()) key in 1068 | let%bind res = Orewa.lindex conn key 1 in 1069 | Alcotest.(check soe) "Get second element of non-empty list" (Ok (Some element)) res; 1070 | return () 1071 | 1072 | let test_linsert () = 1073 | Orewa.with_connection ~host @@ fun conn -> 1074 | let key = random_key () in 1075 | let element = random_key () in 1076 | let pivot = random_key () in 1077 | let%bind res = Orewa.linsert conn ~key Orewa.Before ~element ~pivot in 1078 | Alcotest.(check ie) "Insert into nonexisting list" (Ok 0) res; 1079 | let%bind _ = Orewa.lpush conn ~element:pivot key in 1080 | let%bind res = Orewa.linsert conn ~key Orewa.Before ~element ~pivot in 1081 | Alcotest.(check ie) "Insert before into existing list" (Ok 2) res; 1082 | let%bind res = Orewa.linsert conn ~key Orewa.After ~element ~pivot in 1083 | Alcotest.(check ie) "Insert after into existing list" (Ok 3) res; 1084 | return () 1085 | 1086 | let test_llen () = 1087 | Orewa.with_connection ~host @@ fun conn -> 1088 | let key = random_key () in 1089 | let element = random_key () in 1090 | let%bind res = Orewa.llen conn key in 1091 | Alcotest.(check ie) "Lenght of nonexisting list" (Ok 0) res; 1092 | let%bind _ = Orewa.lpush conn ~element key in 1093 | let%bind res = Orewa.llen conn key in 1094 | Alcotest.(check ie) "Lenght of existing list" (Ok 1) res; 1095 | return () 1096 | 1097 | let test_lpop () = 1098 | Orewa.with_connection ~host @@ fun conn -> 1099 | let key = random_key () in 1100 | let not_list = random_key () in 1101 | let element = random_key () in 1102 | let left_element = random_key () in 1103 | let%bind res = Orewa.lpop conn key in 1104 | Alcotest.(check soe) "Pop from empty key" (Ok None) res; 1105 | let%bind _ = Orewa.set conn ~key:not_list "this is not a list" in 1106 | let%bind res = Orewa.lpop conn not_list in 1107 | Alcotest.(check soe) "Pop from not a list" (Error (`Wrong_type not_list)) res; 1108 | let%bind _ = Orewa.lpush conn ~element key in 1109 | let%bind _ = Orewa.lpush conn ~element:left_element key in 1110 | let%bind res = Orewa.lpop conn key in 1111 | Alcotest.(check soe) "Pop from existing list" (Ok (Some left_element)) res; 1112 | return () 1113 | 1114 | let test_rpop () = 1115 | Orewa.with_connection ~host @@ fun conn -> 1116 | let key = random_key () in 1117 | let not_list = random_key () in 1118 | let element = random_key () in 1119 | let right_element = random_key () in 1120 | let%bind res = Orewa.rpop conn key in 1121 | Alcotest.(check soe) "Pop from empty key" (Ok None) res; 1122 | let%bind _ = Orewa.set conn ~key:not_list "this is not a list" in 1123 | let%bind res = Orewa.rpop conn not_list in 1124 | Alcotest.(check soe) "Pop from not a list" (Error (`Wrong_type not_list)) res; 1125 | let%bind _ = Orewa.lpush conn ~element:right_element key in 1126 | let%bind _ = Orewa.lpush conn ~element key in 1127 | let%bind res = Orewa.rpop conn key in 1128 | Alcotest.(check soe) "Pop from existing list" (Ok (Some right_element)) res; 1129 | return () 1130 | 1131 | let test_lrem () = 1132 | Orewa.with_connection ~host @@ fun conn -> 1133 | let key = random_key () in 1134 | let element = random_key () in 1135 | let%bind _ = Orewa.lpush conn key ~element in 1136 | let%bind _ = Orewa.lpush conn key ~element in 1137 | let%bind _ = Orewa.lpush conn key ~element:"SPACER" in 1138 | let%bind _ = Orewa.lpush conn key ~element in 1139 | let%bind _ = Orewa.lpush conn key ~element in 1140 | let%bind res = Orewa.lrem conn ~key 1 ~element in 1141 | Alcotest.(check ie) "Removing first occurence" (Ok 1) res; 1142 | let%bind res = Orewa.lrem conn ~key 1 ~element in 1143 | Alcotest.(check ie) "Removing second occurence" (Ok 1) res; 1144 | let%bind res = Orewa.lrem conn ~key (-2) ~element in 1145 | Alcotest.(check ie) "Removing final two occurence" (Ok 2) res; 1146 | let%bind res = Orewa.llen conn key in 1147 | Alcotest.(check ie) "Removing final two occurence" (Ok 1) res; 1148 | let%bind res = Orewa.lrem conn ~key 1 ~element in 1149 | Alcotest.(check ie) "Trying to remove not existing element" (Ok 0) res; 1150 | return () 1151 | 1152 | let test_lset () = 1153 | Orewa.with_connection ~host @@ fun conn -> 1154 | let key = random_key () in 1155 | let element = random_key () in 1156 | let%bind res = Orewa.lset conn ~key 0 ~element in 1157 | Alcotest.(check ue) "Setting nonexistent list" (Error (`No_such_key key)) res; 1158 | let%bind _ = Orewa.lpush conn key ~element in 1159 | let%bind res = Orewa.lset conn ~key 0 ~element in 1160 | Alcotest.(check ue) "Setting existent index of list" (Ok ()) res; 1161 | let%bind res = Orewa.lset conn ~key 1 ~element in 1162 | Alcotest.(check ue) 1163 | "Setting non-existent index of list" 1164 | (Error (`Index_out_of_range key)) 1165 | res; 1166 | return () 1167 | 1168 | let test_ltrim () = 1169 | Orewa.with_connection ~host @@ fun conn -> 1170 | let key = random_key () in 1171 | let element = random_key () in 1172 | let elements = 10 in 1173 | let%bind _ = 1174 | List.init elements ~f:(fun _ -> Orewa.lpush conn key ~element) |> Deferred.all 1175 | in 1176 | let%bind res = Orewa.ltrim conn ~start:0 ~end':4 key in 1177 | Alcotest.(check ue) "Trimming list" (Ok ()) res; 1178 | let%bind res = Orewa.llen conn key in 1179 | Alcotest.(check ie) "List is trimmed" (Ok 5) res; 1180 | return () 1181 | 1182 | let test_hset () = 1183 | Orewa.with_connection ~host @@ fun conn -> 1184 | let key = random_key () in 1185 | let random_element () = 1186 | let field = random_key () in 1187 | let value = random_key () in 1188 | field, value 1189 | in 1190 | let element = random_element () in 1191 | let%bind res = Orewa.hset conn ~element key in 1192 | Alcotest.(check ie) "Set single element" (Ok 1) res; 1193 | let%bind res = Orewa.hset conn ~element key in 1194 | Alcotest.(check ie) "Resetting is no-op" (Ok 0) res; 1195 | let%bind res = 1196 | Orewa.hset 1197 | conn 1198 | ~element:(random_element ()) 1199 | ~elements:[random_element (); random_element ()] 1200 | key 1201 | in 1202 | Alcotest.(check ie) "Set multiple elements" (Ok 3) res; 1203 | return () 1204 | 1205 | let test_hget () = 1206 | Orewa.with_connection ~host @@ fun conn -> 1207 | let key = random_key () in 1208 | let field = random_key () in 1209 | let value = random_key () in 1210 | let element = field, value in 1211 | let%bind _ = Orewa.hset conn ~element key in 1212 | let%bind res = Orewa.hget conn ~field key in 1213 | Alcotest.(check se) "Getting the value that was set" (Ok value) res; 1214 | return () 1215 | 1216 | let test_hmget () = 1217 | Orewa.with_connection ~host @@ fun conn -> 1218 | let key = random_key () in 1219 | let field = random_key () in 1220 | let value = random_key () in 1221 | let element = field, value in 1222 | let%bind res = Orewa.hmget conn ~fields:[field] key in 1223 | let expected = String.Map.of_alist_exn [] in 1224 | Alcotest.(check sme) "Getting empty key" (Ok expected) res; 1225 | let%bind _ = Orewa.hset conn ~element key in 1226 | let%bind res = Orewa.hmget conn ~fields:[field] key in 1227 | let expected = String.Map.of_alist_exn [element] in 1228 | Alcotest.(check sme) "Getting the value that was set" (Ok expected) res; 1229 | return () 1230 | 1231 | let test_hgetall () = 1232 | Orewa.with_connection ~host @@ fun conn -> 1233 | let key = random_key () in 1234 | let%bind res = Orewa.hgetall conn key in 1235 | let expected = String.Map.of_alist_exn [] in 1236 | Alcotest.(check sme) "Getting an empty map on empty key" (Ok expected) res; 1237 | let field = random_key () in 1238 | let value = random_key () in 1239 | let element = field, value in 1240 | let%bind _ = Orewa.hset conn ~element key in 1241 | let%bind res = Orewa.hgetall conn key in 1242 | let expected = String.Map.of_alist_exn [element] in 1243 | Alcotest.(check sme) "Getting a map of elements" (Ok expected) res; 1244 | return () 1245 | 1246 | let test_hdel () = 1247 | Orewa.with_connection ~host @@ fun conn -> 1248 | let key = random_key () in 1249 | let field = random_key () in 1250 | let value = random_key () in 1251 | let element = field, value in 1252 | let%bind res = Orewa.hdel conn ~field key in 1253 | Alcotest.(check ie) "Deleting from empty hashtable" (Ok 0) res; 1254 | let field' = random_key () in 1255 | let element' = field', value in 1256 | let field'' = random_key () in 1257 | let element'' = field'', value in 1258 | let%bind _ = Orewa.hset conn ~element ~elements:[element'; element''] key in 1259 | let%bind res = Orewa.hdel conn ~field key in 1260 | Alcotest.(check ie) "Single delete from filled hashtable" (Ok 1) res; 1261 | let%bind res = Orewa.hdel conn ~field:field' ~fields:[field''] key in 1262 | Alcotest.(check ie) "Single delete from filled hashtable" (Ok 2) res; 1263 | return () 1264 | 1265 | let test_hexists () = 1266 | Orewa.with_connection ~host @@ fun conn -> 1267 | let key = random_key () in 1268 | let field = random_key () in 1269 | let value = random_key () in 1270 | let element = field, value in 1271 | let%bind res = Orewa.hexists conn ~field key in 1272 | Alcotest.(check be) "Asking for nonexisting field on missing key" (Ok false) res; 1273 | let%bind _ = Orewa.hset conn ~element key in 1274 | let%bind res = Orewa.hexists conn ~field key in 1275 | Alcotest.(check be) "Asking for existing key" (Ok true) res; 1276 | let%bind _ = Orewa.hdel conn ~field key in 1277 | let%bind res = Orewa.hexists conn ~field key in 1278 | Alcotest.(check be) "Asking for deleted key" (Ok false) res; 1279 | return () 1280 | 1281 | let test_hincrby () = 1282 | Orewa.with_connection ~host @@ fun conn -> 1283 | let key = random_key () in 1284 | let field = random_key () in 1285 | let value = 42 in 1286 | let%bind res = Orewa.hincrby conn ~field key value in 1287 | Alcotest.(check ie) "Incrementing missing key" (Ok value) res; 1288 | let%bind res = Orewa.hincrby conn ~field key value in 1289 | Alcotest.(check ie) "Incrementing existing key" (Ok (2 * value)) res; 1290 | return () 1291 | 1292 | let test_hincrbyfloat () = 1293 | Orewa.with_connection ~host @@ fun conn -> 1294 | let key = random_key () in 1295 | let field = random_key () in 1296 | let value = 42. in 1297 | let%bind res = Orewa.hincrbyfloat conn ~field key value in 1298 | Alcotest.(check fe) "Incrementing missing key" (Ok value) res; 1299 | let%bind res = Orewa.hincrbyfloat conn ~field key value in 1300 | Alcotest.(check fe) "Incrementing existing key" (Ok Float.(2. * value)) res; 1301 | return () 1302 | 1303 | let test_hkeys () = 1304 | Orewa.with_connection ~host @@ fun conn -> 1305 | let key = random_key () in 1306 | let field = random_key () in 1307 | let value = random_key () in 1308 | let element = field, value in 1309 | let%bind res = Orewa.hkeys conn key in 1310 | Alcotest.(check sle) "Empty hash map" (Ok []) res; 1311 | let%bind _ = Orewa.hset conn ~element key in 1312 | let%bind res = Orewa.hkeys conn key in 1313 | Alcotest.(check sle) "Enumerating existing key" (Ok [field]) res; 1314 | return () 1315 | 1316 | let test_hvals () = 1317 | Orewa.with_connection ~host @@ fun conn -> 1318 | let key = random_key () in 1319 | let field = random_key () in 1320 | let value = random_key () in 1321 | let element = field, value in 1322 | let%bind res = Orewa.hvals conn key in 1323 | Alcotest.(check sle) "Empty hash map" (Ok []) res; 1324 | let%bind _ = Orewa.hset conn ~element key in 1325 | let%bind res = Orewa.hvals conn key in 1326 | Alcotest.(check sle) "Enumerating existing key" (Ok [value]) res; 1327 | return () 1328 | 1329 | let test_hlen () = 1330 | Orewa.with_connection ~host @@ fun conn -> 1331 | let key = random_key () in 1332 | let field = random_key () in 1333 | let value = random_key () in 1334 | let element = field, value in 1335 | let%bind res = Orewa.hlen conn key in 1336 | Alcotest.(check ie) "Empty hash map" (Ok 0) res; 1337 | let%bind _ = Orewa.hset conn ~element key in 1338 | let%bind res = Orewa.hlen conn key in 1339 | Alcotest.(check ie) "Map with fields" (Ok 1) res; 1340 | return () 1341 | 1342 | let test_hstrlen () = 1343 | Orewa.with_connection ~host @@ fun conn -> 1344 | let key = random_key () in 1345 | let field = random_key () in 1346 | let value = random_key () in 1347 | let element = field, value in 1348 | let%bind res = Orewa.hstrlen conn ~field key in 1349 | Alcotest.(check ie) "Empty hash map" (Ok 0) res; 1350 | let%bind _ = Orewa.hset conn ~element key in 1351 | let%bind res = Orewa.hstrlen conn ~field key in 1352 | Alcotest.(check ie) "Map with a field" (Ok (String.length value)) res; 1353 | return () 1354 | 1355 | let test_hscan () = 1356 | Orewa.with_connection ~host @@ fun conn -> 1357 | let key = random_key () in 1358 | let count = 20 in 1359 | let elements = 1360 | List.init count ~f:(fun i -> 1361 | String.concat ~sep:":" ["mem"; string_of_int i], random_key ()) 1362 | in 1363 | let%bind _ = Orewa.hset conn key ~element:("dummy", "whatever") ~elements in 1364 | let pattern = "mem:*" in 1365 | let pipe = Orewa.hscan conn ~pattern ~count:4 key in 1366 | let%bind q = Pipe.read_all pipe in 1367 | let res = Queue.to_list q in 1368 | Alcotest.(check unordered_string_tuple_list) 1369 | "Returns the right key/value pairs" 1370 | elements 1371 | res; 1372 | return () 1373 | 1374 | let test_publish () = 1375 | Orewa.with_connection ~host @@ fun conn -> 1376 | let key = random_key () in 1377 | let%bind res = Orewa.publish conn ~channel:key "aaaa" in 1378 | Alcotest.(check ie) "PUBLISH failed" (Ok 0) res; 1379 | return () 1380 | 1381 | let tests = 1382 | Alcotest_async. 1383 | [ test_case "ECHO" `Slow test_echo; 1384 | test_case "SET" `Slow test_set; 1385 | test_case "GET" `Slow test_get; 1386 | test_case "MGET" `Slow test_mget; 1387 | test_case "MSET" `Slow test_mset; 1388 | test_case "MSETNX" `Slow test_msetnx; 1389 | test_case "GETRANGE" `Slow test_getrange; 1390 | test_case "Large SET/GET" `Slow test_large_set_get; 1391 | test_case "RPOPLPUSH" `Slow test_rpoplpush; 1392 | test_case "SET with expiry" `Slow test_set_expiry; 1393 | test_case "LPUSH" `Slow test_lpush; 1394 | test_case "RPUSH" `Slow test_rpush; 1395 | test_case "LPOP" `Slow test_lpop; 1396 | test_case "RPOP" `Slow test_rpop; 1397 | test_case "LRANGE" `Slow test_lpush_lrange; 1398 | test_case "LREM" `Slow test_lrem; 1399 | test_case "LSET" `Slow test_lset; 1400 | test_case "LTRIM" `Slow test_ltrim; 1401 | test_case "Large LRANGE" `Slow test_large_lrange; 1402 | test_case "APPEND" `Slow test_append; 1403 | test_case "AUTH" `Slow test_auth; 1404 | test_case "BGREWRITEAOF" `Slow test_bgrewriteaof; 1405 | test_case "BGSAVE" `Slow test_bgsave; 1406 | test_case "BITCOUNT" `Slow test_bitcount; 1407 | test_case "BITFIELD" `Slow test_bitfield; 1408 | test_case "BITOP" `Slow test_bitop; 1409 | test_case "BITPOS" `Slow test_bitpos; 1410 | test_case "GETBIT" `Slow test_getbit; 1411 | test_case "GETSET" `Slow test_getset; 1412 | test_case "STRLEN" `Slow test_strlen; 1413 | test_case "SETBIT" `Slow test_setbit; 1414 | test_case "DECR" `Slow test_decr; 1415 | test_case "DECRBY" `Slow test_decrby; 1416 | test_case "INCR" `Slow test_incr; 1417 | test_case "INCRBY" `Slow test_incrby; 1418 | test_case "INCRBYFLOAT" `Slow test_incrbyfloat; 1419 | test_case "SELECT" `Slow test_select; 1420 | test_case "DEL" `Slow test_del; 1421 | test_case "EXISTS" `Slow test_exists; 1422 | test_case "EXPIRE" `Slow test_expire; 1423 | test_case "EXPIREAT" `Slow test_expireat; 1424 | test_case "KEYS" `Slow test_keys; 1425 | test_case "SADD" `Slow test_sadd; 1426 | test_case "SCARD" `Slow test_scard; 1427 | test_case "SDIFF" `Slow test_sdiff; 1428 | test_case "SDIFFSTORE" `Slow test_sdiffstore; 1429 | test_case "SINTER" `Slow test_sinter; 1430 | test_case "SINTERSTORE" `Slow test_sinterstore; 1431 | test_case "SISMEMBER" `Slow test_sismember; 1432 | test_case "SMEMBERS" `Slow test_smembers; 1433 | test_case "SPOP" `Slow test_spop; 1434 | test_case "SRANDMEMBER" `Slow test_srandmember; 1435 | test_case "SREM" `Slow test_srem; 1436 | test_case "SUNION" `Slow test_sunion; 1437 | test_case "SUNIONSTORE" `Slow test_sunionstore; 1438 | test_case "SSCAN" `Slow test_sscan; 1439 | test_case "SCAN" `Slow test_scan; 1440 | test_case "MOVE" `Slow test_move; 1441 | test_case "PERSIST" `Slow test_persist; 1442 | test_case "RANDOMKEY" `Slow test_randomkey; 1443 | test_case "RENAME" `Slow test_rename; 1444 | test_case "RENAMENX" `Slow test_renamenx; 1445 | test_case "SORT" `Slow test_sort; 1446 | test_case "TTL" `Slow test_ttl; 1447 | test_case "TYPE" `Slow test_type'; 1448 | test_case "DUMP" `Slow test_dump; 1449 | test_case "RESTORE" `Slow test_restore; 1450 | test_case "PIPELINE" `Slow test_pipelining; 1451 | test_case "CLOSE" `Slow test_close; 1452 | test_case "LINSERT" `Slow test_linsert; 1453 | test_case "LLEN" `Slow test_llen; 1454 | test_case "LINDEX" `Slow test_lindex; 1455 | test_case "HSET" `Slow test_hset; 1456 | test_case "HGET" `Slow test_hget; 1457 | test_case "HMGET" `Slow test_hmget; 1458 | test_case "HGETALL" `Slow test_hgetall; 1459 | test_case "HDEL" `Slow test_hdel; 1460 | test_case "HEXISTS" `Slow test_hexists; 1461 | test_case "HINCRBY" `Slow test_hincrby; 1462 | test_case "HINCRBYFLOAT" `Slow test_hincrbyfloat; 1463 | test_case "HKEYS" `Slow test_hkeys; 1464 | test_case "HVALS" `Slow test_hvals; 1465 | test_case "HLEN" `Slow test_hlen; 1466 | test_case "HSTRLEN" `Slow test_hstrlen; 1467 | test_case "HSCAN" `Slow test_hscan; 1468 | test_case "PUBLISH" `Slow test_publish ] 1469 | 1470 | let () = 1471 | Log.Global.set_level `Debug; 1472 | Alcotest.run Caml.__MODULE__ ["integration", tests] 1473 | --------------------------------------------------------------------------------