├── .gitignore ├── validate_test ├── dune ├── err.ml ├── validate_test.ml ├── custom.ml ├── option.ml ├── regex.ml ├── length.ml └── helper.ml ├── validate ├── validate.ml ├── dune ├── custom.ml ├── option.ml ├── length.ml ├── value.ml ├── err.ml ├── regex.ml └── helper.ml ├── ppx_derive_validate_test ├── error.ml ├── dune ├── ppx_derive_validate_test.ml ├── tuple.ml ├── recursive.ml ├── abstract.ml ├── variant.ml ├── conditional.ml └── record.ml ├── ppx_derive_validate ├── dune ├── pats.ml ├── simple_type.ml ├── ppx_derive_validate.ml ├── exps.ml └── validators.ml ├── .github └── workflows │ └── test.yml ├── LICENSE ├── dune-project ├── CHANGELOG.md ├── validate.opam └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | _opam/ 3 | _coverage/ 4 | -------------------------------------------------------------------------------- /validate_test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name validate_test) 3 | (libraries validate alcotest)) 4 | -------------------------------------------------------------------------------- /validate_test/err.ml: -------------------------------------------------------------------------------- 1 | let validation_error_testable = 2 | Alcotest.testable Validate.pp_validation_error Validate.equal_validation_error 3 | -------------------------------------------------------------------------------- /validate/validate.ml: -------------------------------------------------------------------------------- 1 | include Err 2 | include Length 3 | include Helper 4 | include Custom 5 | include Regex 6 | include Value 7 | include Option 8 | -------------------------------------------------------------------------------- /validate_test/validate_test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let open Alcotest in 3 | run "Validate" (Length.t @ Helper.t @ Custom.t @ Regex.t @ Option.t) 4 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/error.ml: -------------------------------------------------------------------------------- 1 | let validation_error_testable = 2 | Alcotest.testable Validate.pp_validation_error Validate.equal_validation_error 3 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name ppx_derive_validate_test) 3 | (preprocess (pps ppx_derive_validate ppx_deriving.show ppx_deriving.eq)) 4 | (libraries validate alcotest)) 5 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/ppx_derive_validate_test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let open Alcotest in 3 | run "Validate" 4 | [ Abstract.t; Record.t; Tuple.t; Variant.t; Recursive.t; Conditional.t ] 5 | -------------------------------------------------------------------------------- /validate/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name validate) 3 | (public_name validate) 4 | (libraries re uri) 5 | (instrumentation (backend bisect_ppx)) 6 | (preprocess (pps ppx_deriving.show ppx_deriving.eq))) 7 | -------------------------------------------------------------------------------- /validate/custom.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let validate_url url_string = 4 | let uri = Uri.of_string url_string in 5 | match (Uri.scheme uri, Uri.host uri) with 6 | | Some _, Some _ -> Ok () 7 | | _ -> Error (BaseError { code = invalid_url_error_code; params = [] }) 8 | -------------------------------------------------------------------------------- /ppx_derive_validate/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name ppx_derive_validate) 3 | (public_name validate.ppx_derive_validate) 4 | (libraries ppxlib) 5 | (kind ppx_deriver) 6 | (instrumentation (backend bisect_ppx)) 7 | (preprocess (pps ppxlib.metaquot ppx_deriving.show ppx_deriving.eq))) 8 | -------------------------------------------------------------------------------- /ppx_derive_validate/pats.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_helper 3 | 4 | let var_pat ~loc name = Pat.var { txt = name; loc } 5 | 6 | let n_element_tuple_pat ~prefix ~loc n = 7 | match n with 8 | | 0 -> Pat.construct { txt = Lident "()"; loc } None 9 | | 1 -> var_pat ~loc (Printf.sprintf "%s0" prefix) 10 | | _ -> 11 | Pat.tuple 12 | (List.init n (fun i -> var_pat ~loc (Printf.sprintf "%s%d" prefix i))) 13 | 14 | let record_pat ~loc fields = 15 | let fields = 16 | List.map 17 | (fun name -> ({ txt = Lident name; loc }, Pat.var { txt = name; loc })) 18 | fields 19 | in 20 | Pat.record fields Closed 21 | -------------------------------------------------------------------------------- /validate_test/custom.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let test_validate_url_error () = 4 | let result = Validate.validate_url "invalid_url" in 5 | 6 | Alcotest.(check (result unit validation_error_testable)) 7 | "validate_url" 8 | (Error (Validate.BaseError { code = "invalid_url"; params = [] })) 9 | result 10 | 11 | let test_validate_url_success () = 12 | let result = Validate.validate_url "https://www.google.com" in 13 | 14 | Alcotest.(check (result unit validation_error_testable)) 15 | "validate_url" (Ok ()) result 16 | 17 | let validate_url = 18 | let open Alcotest in 19 | ( "validate_url", 20 | [ 21 | test_case "Error - invalid url" `Quick test_validate_url_error; 22 | test_case "Success" `Quick test_validate_url_success; 23 | ] ) 24 | 25 | let t = [ validate_url ] 26 | -------------------------------------------------------------------------------- /.github/workflows/test.yml: -------------------------------------------------------------------------------- 1 | name: Tests 2 | 3 | on: 4 | pull_request: 5 | branches: [master] 6 | push: 7 | branches: [master] 8 | 9 | jobs: 10 | build: 11 | name: Test 12 | runs-on: ubuntu-latest 13 | steps: 14 | - name: Checkout code 15 | uses: actions/checkout@v3 16 | 17 | - name: Setup Ocaml 18 | uses: ocaml/setup-ocaml@v2 19 | with: 20 | ocaml-compiler: 5.1.1 21 | 22 | - name: Install dependencies 23 | run: opam install . --deps-only --with-test 24 | 25 | - name: Build 26 | run: opam exec -- dune build --verbose 27 | 28 | - name: Test 29 | run: opam exec -- dune runtest --verbose 30 | 31 | - name: Coverage 32 | env: 33 | CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} 34 | PULL_REQUEST_NUMBER: ${{ github.event.number }} 35 | run: | 36 | opam exec -- dune runtest --instrument-with bisect_ppx --force 37 | opam exec -- bisect-ppx-report send-to Codecov 38 | -------------------------------------------------------------------------------- /validate/option.ml: -------------------------------------------------------------------------------- 1 | let validate_some (value : 'a option) = 2 | match value with 3 | | None -> 4 | Error (Err.BaseError { code = Err.expect_some_error_code; params = [] }) 5 | | Some _ -> Ok () 6 | 7 | let validate_some_if (cond : bool) (value : 'a option) = 8 | match (cond, value) with 9 | | true, None -> 10 | Error (Err.BaseError { code = Err.expect_some_error_code; params = [] }) 11 | | false, Some _ -> 12 | Error (Err.BaseError { code = Err.expect_none_error_code; params = [] }) 13 | | _ -> Ok () 14 | 15 | let validate_none (value : 'a option) = 16 | match value with 17 | | None -> Ok () 18 | | Some _ -> 19 | Error (Err.BaseError { code = Err.expect_none_error_code; params = [] }) 20 | 21 | let validate_none_if (cond : bool) (value : 'a option) = 22 | match (cond, value) with 23 | | true, Some _ -> 24 | Error (Err.BaseError { code = Err.expect_none_error_code; params = [] }) 25 | | false, None -> 26 | Error (Err.BaseError { code = Err.expect_some_error_code; params = [] }) 27 | | _ -> Ok () 28 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 Mateusz Ledwoń 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.12) 2 | 3 | (name validate) 4 | 5 | (generate_opam_files true) 6 | 7 | (source 8 | (github Axot017/validate)) 9 | 10 | (authors "Mateusz Ledwoń ") 11 | 12 | (maintainers "Mateusz Ledwoń ") 13 | 14 | (license MIT) 15 | 16 | (documentation https://axot017.github.io/validate/) 17 | 18 | (package 19 | (name validate) 20 | (synopsis "OCaml library enabling efficient data validation through PPX derivers and a suite of annotation-based validators") 21 | (description "Validate is an OCaml library that focuses on data validation using PPX derivers and a range of annotations for different data types. It allows developers to apply annotations for various validation rules, such as string length, numeric values, and format constraints like URLs and UUIDs. This functionality makes it suitable for a wide array of applications in OCaml development where data integrity is crucial.") 22 | (depends (ocaml (>= "5.0.0")) dune (alcotest :with-test) ppx_deriving re uri (bisect_ppx :with-test)) 23 | (tags 24 | (validation ppx))) 25 | 26 | ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 27 | -------------------------------------------------------------------------------- /validate/length.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let validate_min_length get_len min_length value = 4 | let len = get_len value in 5 | if len < min_length then 6 | Error 7 | (BaseError 8 | { 9 | code = min_length_error_code; 10 | params = [ ("threshold", string_of_int min_length) ]; 11 | }) 12 | else Ok () 13 | 14 | let validate_max_length get_len max_length value = 15 | let len = get_len value in 16 | if len > max_length then 17 | Error 18 | (BaseError 19 | { 20 | code = max_length_error_code; 21 | params = [ ("threshold", string_of_int max_length) ]; 22 | }) 23 | else Ok () 24 | 25 | let validate_length_between get_len ~min ~max value = 26 | let res = validate_min_length get_len min value in 27 | match res with 28 | | Ok () -> validate_max_length get_len max value 29 | | Error _ -> res 30 | 31 | let validate_length_equals get_len length value = 32 | let len = get_len value in 33 | if len <> length then 34 | Error 35 | (BaseError 36 | { 37 | code = length_equals_error_code; 38 | params = [ ("value", string_of_int length) ]; 39 | }) 40 | else Ok () 41 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/tuple.ml: -------------------------------------------------------------------------------- 1 | type tuple = (string[@email]) * (int[@greater_than 1]) [@@deriving validate] 2 | 3 | let test_tuple_ok () = 4 | let pair = ("email@test.com", 2) in 5 | let result = validate_tuple pair in 6 | Alcotest.(check (result (pair string int) Error.validation_error_testable)) 7 | "returns Ok" (Ok pair) result 8 | 9 | let test_tuple_error () = 10 | let pair = ("test", 0) in 11 | let result = validate_tuple pair in 12 | Alcotest.(check (result (pair string int) Error.validation_error_testable)) 13 | "returns Ok" 14 | (Error 15 | (Validate.GroupError 16 | [ 17 | Validate.KeyedError 18 | [ 19 | ( "1", 20 | [ 21 | Validate.BaseError 22 | { 23 | code = "value_greater_than"; 24 | params = [ ("threshold", "1") ]; 25 | }; 26 | ] ); 27 | ( "0", 28 | [ Validate.BaseError { code = "invalid_email"; params = [] } ] 29 | ); 30 | ]; 31 | ])) 32 | result 33 | 34 | let t = 35 | let open Alcotest in 36 | ( "tuple", 37 | [ 38 | test_case "tuple - Ok" `Quick test_tuple_ok; 39 | test_case "tuple - Error" `Quick test_tuple_error; 40 | ] ) 41 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## v1.1.0 (2024-02-01) 2 | 3 | - Added new string annotations: 4 | - `@ulid`: Ensures a string is a valid ULID. 5 | - `@ipv4`: Validates that a string is a valid IPv4 address. 6 | - `@ipv6`: Ensures a string is a valid IPv6 address. 7 | - `@phone`: Validates that a string conforms to the E.164 phone number format. 8 | - `@mac_address`: Ensures a string is a valid MAC address. 9 | - Introduced new option type annotations: 10 | - `@some`: Ensures an option type is `Some`. 11 | - `@none`: Ensures an option type is `None`. 12 | - Implemented `@custom` annotation for custom validation logic. 13 | - Added `@ignore_if` annotation for conditional validation. 14 | - Introduced `@some_if` and `@none_if` annotations for conditional requirements on option types. 15 | 16 | ## v1.0.0 (2024-01-26) 17 | 18 | - Added support for validating variants. 19 | - Introduced support for recursive types, enabling the validation of nested self-referential data structures. 20 | - Implemented support for circular recursive types, allowing for validation in complex interconnected data structures. 21 | - API stabilization: The API can now be considered stable. Future changes will primarily focus on adding new validators without altering existing functionality. 22 | 23 | ## v0.2.0 (2024-01-17) 24 | 25 | - Support for simple types 26 | - Support for tuples 27 | - Group error type added 28 | 29 | ## v0.1.0 (2024-01-09) 30 | 31 | - Initial release 32 | -------------------------------------------------------------------------------- /validate.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: 4 | "OCaml library enabling efficient data validation through PPX derivers and a suite of annotation-based validators" 5 | description: 6 | "Validate is an OCaml library that focuses on data validation using PPX derivers and a range of annotations for different data types. It allows developers to apply annotations for various validation rules, such as string length, numeric values, and format constraints like URLs and UUIDs. This functionality makes it suitable for a wide array of applications in OCaml development where data integrity is crucial." 7 | maintainer: ["Mateusz Ledwoń "] 8 | authors: ["Mateusz Ledwoń "] 9 | license: "MIT" 10 | tags: ["validation" "ppx"] 11 | homepage: "https://github.com/Axot017/validate" 12 | doc: "https://axot017.github.io/validate/" 13 | bug-reports: "https://github.com/Axot017/validate/issues" 14 | depends: [ 15 | "ocaml" {>= "5.0.0"} 16 | "dune" {>= "3.12"} 17 | "alcotest" {with-test} 18 | "ppx_deriving" 19 | "re" 20 | "uri" 21 | "bisect_ppx" {with-test} 22 | "odoc" {with-doc} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {dev} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: "git+https://github.com/Axot017/validate.git" 39 | -------------------------------------------------------------------------------- /validate_test/option.ml: -------------------------------------------------------------------------------- 1 | let test_validate_some () = 2 | let value = Some "value" in 3 | let result = Validate.validate_some value in 4 | 5 | Alcotest.(check (result unit Err.validation_error_testable)) 6 | "returns Ok" (Ok ()) result 7 | 8 | let test_validate_some_err () = 9 | let value = None in 10 | let result = Validate.validate_some value in 11 | 12 | Alcotest.(check (result unit Err.validation_error_testable)) 13 | "returns Error" 14 | (Error 15 | (Validate.BaseError 16 | { code = Validate.expect_some_error_code; params = [] })) 17 | result 18 | 19 | let test_validate_none () = 20 | let value = None in 21 | let result = Validate.validate_none value in 22 | 23 | Alcotest.(check (result unit Err.validation_error_testable)) 24 | "returns Ok" (Ok ()) result 25 | 26 | let test_validate_none_err () = 27 | let value = Some "value" in 28 | let result = Validate.validate_none value in 29 | 30 | Alcotest.(check (result unit Err.validation_error_testable)) 31 | "returns Error" 32 | (Error 33 | (Validate.BaseError 34 | { code = Validate.expect_none_error_code; params = [] })) 35 | result 36 | 37 | let required = 38 | let open Alcotest in 39 | ( "required", 40 | [ 41 | test_case "Some - Ok" `Quick test_validate_some; 42 | test_case "Some - Err" `Quick test_validate_some_err; 43 | test_case "None - Ok" `Quick test_validate_none; 44 | test_case "None - Err" `Quick test_validate_none_err; 45 | ] ) 46 | 47 | let t = [ required ] 48 | -------------------------------------------------------------------------------- /validate/value.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let validate_equal_to to_str other value = 4 | if other = value then Ok () 5 | else 6 | Error 7 | (BaseError 8 | { 9 | code = value_equal_to_error_code; 10 | params = [ ("value", to_str other) ]; 11 | }) 12 | 13 | let validate_not_equal_to to_str other value = 14 | if other <> value then Ok () 15 | else 16 | Error 17 | (BaseError 18 | { 19 | code = value_not_equal_to_error_code; 20 | params = [ ("value", to_str other) ]; 21 | }) 22 | 23 | let validate_greater_than to_str other value = 24 | if value > other then Ok () 25 | else 26 | Error 27 | (BaseError 28 | { 29 | code = value_greater_than_error_code; 30 | params = [ ("threshold", to_str other) ]; 31 | }) 32 | 33 | let validate_greater_than_or_equal to_str other value = 34 | if value >= other then Ok () 35 | else 36 | Error 37 | (BaseError 38 | { 39 | code = value_greater_than_or_equal_error_code; 40 | params = [ ("threshold", to_str other) ]; 41 | }) 42 | 43 | let validate_less_than to_str other value = 44 | if value < other then Ok () 45 | else 46 | Error 47 | (BaseError 48 | { 49 | code = value_less_than_error_code; 50 | params = [ ("threshold", to_str other) ]; 51 | }) 52 | 53 | let validate_less_than_or_equal to_str other value = 54 | if value <= other then Ok () 55 | else 56 | Error 57 | (BaseError 58 | { 59 | code = value_less_than_or_equal_error_code; 60 | params = [ ("threshold", to_str other) ]; 61 | }) 62 | -------------------------------------------------------------------------------- /ppx_derive_validate/simple_type.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | 3 | type record_field = { name : string; loc_type : loc_type } 4 | and loc_type = { loc : Location.t; typ : simple_type } 5 | 6 | and simple_type = 7 | | Bool 8 | | Int 9 | | Float 10 | | String 11 | | Option of (simple_type * core_type) 12 | | Other of longident 13 | | List of (simple_type * core_type) 14 | | Tuple of (simple_type * core_type) list 15 | 16 | let rec extract_field_type label_loc (t : core_type) = 17 | let field_type = 18 | match t.ptyp_desc with 19 | | Ptyp_constr ({ txt = Lident "string"; _ }, []) -> String 20 | | Ptyp_constr ({ txt = Lident "int"; _ }, []) -> Int 21 | | Ptyp_constr ({ txt = Lident "bool"; _ }, []) -> Bool 22 | | Ptyp_constr ({ txt = Lident "float"; _ }, []) -> Float 23 | | Ptyp_constr ({ txt = Lident "option"; _ }, [ arg ]) -> 24 | Option (extract_field_type label_loc arg, arg) 25 | | Ptyp_constr ({ txt = Lident "list"; _ }, [ arg ]) -> 26 | List (extract_field_type label_loc arg, arg) 27 | | Ptyp_constr ({ txt = name; _ }, []) -> Other name 28 | | Ptyp_tuple inner_types -> 29 | Tuple 30 | (List.map 31 | (fun t -> 32 | let field_type = extract_field_type label_loc t in 33 | (field_type, t)) 34 | inner_types) 35 | | _ -> Location.raise_errorf ~loc:label_loc "Unsupported type" 36 | in 37 | field_type 38 | 39 | let extract_loc_type (t : core_type) = 40 | { loc = t.ptyp_loc; typ = extract_field_type t.ptyp_loc t } 41 | 42 | let extract_record_field (ld : label_declaration) = 43 | let name = ld.pld_name.txt in 44 | let loc_type = extract_loc_type ld.pld_type in 45 | { name; loc_type } 46 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/recursive.ml: -------------------------------------------------------------------------------- 1 | type tree = 2 | | Leaf of (int[@greater_than 0]) 3 | | Node of { left : tree; [@dive] right : (tree[@dive]) } 4 | [@@deriving validate, show, eq] 5 | 6 | let tree_testable = Alcotest.testable pp_tree equal_tree 7 | 8 | let test_tree () = 9 | let tree = 10 | Node { left = Leaf 1; right = Node { left = Leaf 2; right = Leaf 3 } } 11 | in 12 | let result = validate_tree tree in 13 | Alcotest.(check (result tree_testable Error.validation_error_testable)) 14 | "returns Ok" (Ok tree) result 15 | 16 | type user = { id : int; [@greater_than 0] friends : (user[@dive]) list } 17 | [@@deriving validate, show, eq] 18 | 19 | let user_testable = Alcotest.testable pp_user equal_user 20 | 21 | let test_user () = 22 | let user = { id = 1; friends = [ { id = 2; friends = [] } ] } in 23 | let result = validate_user user in 24 | Alcotest.(check (result user_testable Error.validation_error_testable)) 25 | "returns Ok" (Ok user) result 26 | 27 | type a = { a_id : int; [@greater_than 0] b : (b[@dive]) option } 28 | [@@deriving validate, show, eq] 29 | 30 | and b = { b_id : int; [@greater_than 0] a : (a[@dive]) option } 31 | [@@deriving validate, show, eq] 32 | 33 | let a_testable = Alcotest.testable pp_a equal_a 34 | let b_testable = Alcotest.testable pp_b equal_b 35 | 36 | let test_cycle () = 37 | let a = 38 | { a_id = 1; b = Some { b_id = 2; a = Some { a_id = 3; b = None } } } 39 | in 40 | let result = validate_a a in 41 | Alcotest.(check (result a_testable Error.validation_error_testable)) 42 | "returns Ok" (Ok a) result 43 | 44 | let t = 45 | let open Alcotest in 46 | ( "recursive", 47 | [ 48 | test_case "tree" `Quick test_tree; 49 | test_case "user" `Quick test_user; 50 | test_case "cycle" `Quick test_cycle; 51 | ] ) 52 | -------------------------------------------------------------------------------- /validate/err.ml: -------------------------------------------------------------------------------- 1 | (* Lengt *) 2 | let min_length_error_code = "min_length" 3 | let max_length_error_code = "max_length" 4 | let length_equals_error_code = "length_equals" 5 | 6 | (* Value *) 7 | let value_equal_to_error_code = "value_equal_to" 8 | let value_not_equal_to_error_code = "value_not_equal_to" 9 | let value_greater_than_error_code = "value_greater_than" 10 | let value_greater_than_or_equal_error_code = "value_greater_than_or_equal" 11 | let value_less_than_error_code = "value_less_than" 12 | let value_less_than_or_equal_error_code = "value_less_than_or_equal" 13 | let value_between_error_code = "value_between" 14 | 15 | (* Regex *) 16 | let invalid_pattern_error_code = "invalid_pattern" 17 | let invalid_uuid_error_code = "invalid_uuid" 18 | let invalid_ulid_error_code = "invalid_ulid" 19 | let invalid_numeric_error_code = "invalid_numeric" 20 | let invalid_alpha_error_code = "invalid_alpha" 21 | let invalid_alphanumeric_error_code = "invalid_alphanumeric" 22 | let invalid_lowercase_error_code = "invalid_lowercase" 23 | let invalid_uppercase_error_code = "invalid_uppercase" 24 | let invalid_lowercase_alphanumeric_error_code = "invalid_lowercase_alphanumeric" 25 | let invalid_uppercase_alphanumeric_error_code = "invalid_uppercase_alphanumeric" 26 | let invalid_email_error_code = "invalid_email" 27 | let invalid_ipv4_error_code = "invalid_ipv4" 28 | let invalid_ipv6_error_code = "invalid_ipv6" 29 | let invalid_phone_number_error_code = "invalid_phone_number" 30 | let invalid_mac_address_error_code = "invalid_mac_address" 31 | 32 | (* Custom *) 33 | let invalid_url_error_code = "invalid_url" 34 | 35 | (* Option *) 36 | let expect_some_error_code = "expect_some" 37 | let expect_none_error_code = "expect_none" 38 | 39 | type base_validation_error = { code : string; params : (string * string) list } 40 | [@@deriving show, eq] 41 | 42 | and keyed_validation_errors = string * validation_error list 43 | [@@deriving show, eq] 44 | 45 | and index_validation_error = int * validation_error list [@@deriving show, eq] 46 | 47 | and validation_error = 48 | | BaseError of base_validation_error 49 | | KeyedError of keyed_validation_errors list 50 | | IterableError of index_validation_error list 51 | | GroupError of validation_error list 52 | [@@deriving show, eq] 53 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/abstract.ml: -------------------------------------------------------------------------------- 1 | type simple_string = (string[@email]) [@@deriving validate] 2 | 3 | let test_simple_string_ok () = 4 | let email = "email@test.com" in 5 | let result = validate_simple_string email in 6 | Alcotest.(check (result string Error.validation_error_testable)) 7 | "returns Ok" (Ok email) result 8 | 9 | let test_simple_string_error () = 10 | let email = "" in 11 | let result = validate_simple_string email in 12 | Alcotest.(check (result string Error.validation_error_testable)) 13 | "returns Error" 14 | (Error 15 | (Validate.GroupError 16 | [ Validate.BaseError { code = "invalid_email"; params = [] } ])) 17 | result 18 | 19 | type list_type = ((string[@min_length 1]) list[@min_length 2]) 20 | [@@deriving validate] 21 | 22 | let test_list_type_ok () = 23 | let list = [ "test"; "test" ] in 24 | let result = validate_list_type list in 25 | Alcotest.(check (result (list string) Error.validation_error_testable)) 26 | "returns Ok" (Ok list) result 27 | 28 | let test_list_type_error () = 29 | let list = [ "" ] in 30 | let result = validate_list_type list in 31 | Alcotest.(check (result (list string) Error.validation_error_testable)) 32 | "returns Error" 33 | (Error 34 | (Validate.GroupError 35 | [ 36 | Validate.BaseError 37 | { code = "min_length"; params = [ ("threshold", "2") ] }; 38 | Validate.IterableError 39 | [ 40 | ( 0, 41 | [ 42 | Validate.BaseError 43 | { code = "min_length"; params = [ ("threshold", "1") ] }; 44 | ] ); 45 | ]; 46 | ])) 47 | result 48 | 49 | type optional_type = (string[@min_length 1]) option [@@deriving validate] 50 | 51 | let test_optional_type_none () = 52 | let result = validate_optional_type None in 53 | Alcotest.(check (result (option string) Error.validation_error_testable)) 54 | "returns Ok" (Ok None) result 55 | 56 | let test_optional_type_some_ok () = 57 | let result = validate_optional_type (Some "test") in 58 | Alcotest.(check (result (option string) Error.validation_error_testable)) 59 | "returns Ok" (Ok (Some "test")) result 60 | 61 | let test_optional_type_some_error () = 62 | let result = validate_optional_type (Some "") in 63 | Alcotest.(check (result (option string) Error.validation_error_testable)) 64 | "returns Error" 65 | (Error 66 | (Validate.GroupError 67 | [ 68 | Validate.GroupError 69 | [ 70 | Validate.BaseError 71 | { code = "min_length"; params = [ ("threshold", "1") ] }; 72 | ]; 73 | ])) 74 | result 75 | 76 | let t = 77 | let open Alcotest in 78 | ( "abstract type", 79 | [ 80 | test_case "simple_string - Ok" `Quick test_simple_string_ok; 81 | test_case "simple_string - Error" `Quick test_simple_string_error; 82 | test_case "list_type - Ok" `Quick test_list_type_ok; 83 | test_case "list_type - Error" `Quick test_list_type_error; 84 | test_case "optional_type - None" `Quick test_optional_type_none; 85 | test_case "optional_type - Some Ok" `Quick test_optional_type_some_ok; 86 | test_case "optional_type - Some Error" `Quick 87 | test_optional_type_some_error; 88 | ] ) 89 | -------------------------------------------------------------------------------- /ppx_derive_validate/ppx_derive_validate.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_helper 3 | open Validators 4 | 5 | let map_type_declaration ~loc td = 6 | let body = 7 | match td.ptype_kind with 8 | | Ptype_record label_declarations -> 9 | validate_record_exp ~loc label_declarations 10 | | Ptype_abstract -> 11 | td.ptype_manifest |> Option.get |> validate_abstract_exp ~loc 12 | | Ptype_variant constructor_declarations -> 13 | validate_variant_exp ~loc constructor_declarations 14 | | _ -> Location.raise_errorf ~loc "Unsupported type" 15 | in 16 | let type_name = td.ptype_name.txt in 17 | 18 | let param_pattern = Pat.var { txt = "x"; loc } in 19 | let param_type = Typ.constr { txt = Lident type_name; loc } [] in 20 | let typed_param_pattern = Pat.constraint_ param_pattern param_type in 21 | let func_expr = Exp.fun_ Nolabel None typed_param_pattern body in 22 | 23 | let function_name = "validate_" ^ type_name in 24 | 25 | let function_pattern = Pat.var { txt = function_name; loc } in 26 | 27 | Vb.mk function_pattern func_expr 28 | 29 | let map_sig ~loc td = 30 | match td.ptype_kind with 31 | | Ptype_abstract | Ptype_record _ -> 32 | let record_name = td.ptype_name.txt in 33 | let function_name = "validate_" ^ record_name in 34 | let function_name_loc = { txt = function_name; loc } in 35 | 36 | let input_type = Typ.constr { txt = Lident record_name; loc } [] in 37 | let output_type = 38 | Typ.constr 39 | { txt = Ldot (Lident "Validate", "validation_error"); loc } 40 | [] 41 | in 42 | let result_type = 43 | Typ.constr { txt = Lident "result"; loc } [ input_type; output_type ] 44 | in 45 | let function_type = Typ.arrow Nolabel input_type result_type in 46 | Sig.value (Val.mk function_name_loc function_type) 47 | | _ -> Location.raise_errorf ~loc "Unsupported type" 48 | 49 | let is_recursive names td = 50 | match td.ptype_kind with 51 | | Ptype_record label_declarations -> 52 | names |> List.exists (lds_has_recursive label_declarations) 53 | | Ptype_abstract -> 54 | let ct = Option.get td.ptype_manifest in 55 | names |> List.exists (cts_has_recursive [ ct ]) 56 | | Ptype_variant constructor_declarations -> 57 | let recursive cd = 58 | match cd.pcd_args with 59 | | Pcstr_tuple cts -> names |> List.exists (cts_has_recursive cts) 60 | | Pcstr_record lds -> names |> List.exists (lds_has_recursive lds) 61 | in 62 | constructor_declarations |> List.exists recursive 63 | | _ -> false 64 | 65 | let generate_impl ~ctxt (_rec_flag, type_declarations) = 66 | let names = type_declarations |> List.map (fun td -> td.ptype_name.txt) in 67 | let is_recursive = type_declarations |> List.exists (is_recursive names) in 68 | let rec_flag = if is_recursive then Recursive else Nonrecursive in 69 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 70 | [ 71 | type_declarations 72 | |> List.map (map_type_declaration ~loc) 73 | |> Str.value rec_flag; 74 | ] 75 | 76 | let generate_intf ~ctxt (_rec_flag, type_declarations) = 77 | let loc = Expansion_context.Deriver.derived_item_loc ctxt in 78 | type_declarations |> List.map (map_sig ~loc) 79 | 80 | let () = 81 | let impl_generator = Deriving.Generator.V2.make_noarg generate_impl in 82 | let intf_generator = Deriving.Generator.V2.make_noarg generate_intf in 83 | Deriving.add "validate" ~str_type_decl:impl_generator 84 | ~sig_type_decl:intf_generator 85 | |> Deriving.ignore 86 | -------------------------------------------------------------------------------- /validate/regex.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let uuid_regex = 4 | Re.Perl.re 5 | "^[a-fA-F0-9]{8}-[a-fA-F0-9]{4}-[a-fA-F0-9]{4}-[a-fA-F0-9]{4}-[a-fA-F0-9]{12}$" 6 | |> Re.compile 7 | 8 | let ulid_regex = Re.Perl.re "^[0-9A-HJKMNP-TV-Z]{26}$" |> Re.compile 9 | 10 | let ipv4_regex = 11 | Re.Perl.re 12 | {|^(\b25[0-5]|\b2[0-4][0-9]|\b[01]?[0-9][0-9]?)(\.(25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?)){3}$|} 13 | |> Re.compile 14 | 15 | let ipv6_regex = 16 | Re.Perl.re 17 | {|^(([0-9a-fA-F]{1,4}:){7,7}[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,7}:|([0-9a-fA-F]{1,4}:){1,6}:[0-9a-fA-F]{1,4}|([0-9a-fA-F]{1,4}:){1,5}(:[0-9a-fA-F]{1,4}){1,2}|([0-9a-fA-F]{1,4}:){1,4}(:[0-9a-fA-F]{1,4}){1,3}|([0-9a-fA-F]{1,4}:){1,3}(:[0-9a-fA-F]{1,4}){1,4}|([0-9a-fA-F]{1,4}:){1,2}(:[0-9a-fA-F]{1,4}){1,5}|[0-9a-fA-F]{1,4}:((:[0-9a-fA-F]{1,4}){1,6})|:((:[0-9a-fA-F]{1,4}){1,7}|:)|fe80:(:[0-9a-fA-F]{0,4}){0,4}%[0-9a-zA-Z]{1,}|::(ffff(:0{1,4}){0,1}:){0,1}((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])|([0-9a-fA-F]{1,4}:){1,4}:((25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9])\.){3,3}(25[0-5]|(2[0-4]|1{0,1}[0-9]){0,1}[0-9]))$|} 18 | |> Re.compile 19 | 20 | let mac_address_regex = 21 | Re.Perl.re {|^[a-fA-F0-9]{2}(:[a-fA-F0-9]{2}){5}$|} |> Re.compile 22 | 23 | let phone_number_regex = Re.Perl.re {|^\+[1-9]\d{1,14}$|} |> Re.compile 24 | let numeric_regex = Re.Perl.re "^[0-9]*$" |> Re.compile 25 | let alpha_regex = Re.Perl.re "^[a-zA-Z]*$" |> Re.compile 26 | let alphanumeric_regex = Re.Perl.re "^[a-zA-Z0-9]*$" |> Re.compile 27 | let lowercase_regex = Re.Perl.re "^[a-z]*$" |> Re.compile 28 | let uppercase_regex = Re.Perl.re "^[A-Z]*$" |> Re.compile 29 | let lowercase_alphanumeric_regex = Re.Perl.re "^[a-z0-9]*$" |> Re.compile 30 | let uppercase_alphanumeric_regex = Re.Perl.re "^[A-Z0-9]*$" |> Re.compile 31 | 32 | let email_regex = 33 | Re.Perl.re 34 | "^[a-z0-9!#$%&'*+/=?^_`{|}~-]+(?:\\.[a-z0-9!#$%&'*+/=?^_`{|}~-]+)*@(?:[a-z0-9](?:[a-z0-9-]*[a-z0-9])?\\.)+[a-z0-9](?:[a-z0-9-]*[a-z0-9])?$" 35 | |> Re.compile 36 | 37 | let _validate_regex code regex str = 38 | let result = Re.execp regex str in 39 | if result then Ok () else Error (BaseError { code; params = [] }) 40 | 41 | let validate_regex regex str = 42 | _validate_regex invalid_pattern_error_code regex str 43 | 44 | let validate_str_regex regex = 45 | let compiled_regex = Re.Perl.re regex |> Re.compile in 46 | fun str -> validate_regex compiled_regex str 47 | 48 | let validate_uuid uuid = _validate_regex invalid_uuid_error_code uuid_regex uuid 49 | let validate_ulid uuid = _validate_regex invalid_ulid_error_code ulid_regex uuid 50 | let validate_ipv4 str = _validate_regex invalid_ipv4_error_code ipv4_regex str 51 | let validate_ipv6 str = _validate_regex invalid_ipv6_error_code ipv6_regex str 52 | 53 | let validate_mac_address str = 54 | _validate_regex invalid_mac_address_error_code mac_address_regex str 55 | 56 | let validate_phone_number str = 57 | _validate_regex invalid_phone_number_error_code phone_number_regex str 58 | 59 | let validate_numeric str = 60 | _validate_regex invalid_numeric_error_code numeric_regex str 61 | 62 | let validate_alpha str = 63 | _validate_regex invalid_alpha_error_code alpha_regex str 64 | 65 | let validate_alphanumeric str = 66 | _validate_regex invalid_alphanumeric_error_code alphanumeric_regex str 67 | 68 | let validate_lowercase str = 69 | _validate_regex invalid_lowercase_error_code lowercase_regex str 70 | 71 | let validate_uppercase str = 72 | _validate_regex invalid_uppercase_error_code uppercase_regex str 73 | 74 | let validate_lowercase_alphanumeric str = 75 | _validate_regex invalid_lowercase_alphanumeric_error_code 76 | lowercase_alphanumeric_regex str 77 | 78 | let validate_uppercase_alphanumeric str = 79 | _validate_regex invalid_uppercase_alphanumeric_error_code 80 | uppercase_alphanumeric_regex str 81 | 82 | let validate_email str = 83 | _validate_regex invalid_email_error_code email_regex str 84 | -------------------------------------------------------------------------------- /validate/helper.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | type 'a validator = 'a -> (unit, validation_error) result 4 | and ('a, 'b) field_extractor = 'a -> 'b 5 | and ('a, 'b) named_value_extractor = 'a -> 'b option 6 | and 'a keyed_validator = 'a -> (unit, keyed_validation_errors) result 7 | 8 | let validate (validator : 'a validator) (value : 'a) : 9 | ('a, validation_error) result = 10 | match validator value with Ok _ -> Ok value | Error error -> Error error 11 | 12 | let field field_name (field_extractor : ('a, 'b) field_extractor) 13 | (validators : 'b validator list) record : 14 | (unit, keyed_validation_errors) result = 15 | let value = field_extractor record in 16 | let rec validate validators errors = 17 | match validators with 18 | | [] -> errors 19 | | validator :: rest -> ( 20 | match validator value with 21 | | Ok _ -> validate rest errors 22 | | Error error -> validate rest (error :: errors)) 23 | in 24 | let errors = validate validators [] in 25 | match errors with [] -> Ok () | errors -> Error (field_name, errors) 26 | 27 | let keyed (validators : 'a keyed_validator list) record : 28 | (unit, validation_error) result = 29 | let rec validate validators errors = 30 | match validators with 31 | | [] -> errors 32 | | validator :: rest -> ( 33 | match validator record with 34 | | Ok _ -> validate rest errors 35 | | Error error -> validate rest (error :: errors)) 36 | in 37 | let errors = validate validators [] in 38 | match errors with [] -> Ok () | errors -> Error (KeyedError errors) 39 | 40 | let named_value name (extractor : ('a, 'b) named_value_extractor) 41 | (validators : 'b validator list) variant : 42 | (unit, keyed_validation_errors) result = 43 | let value = extractor variant in 44 | match value with 45 | | Some value -> ( 46 | let rec validate validators errors = 47 | match validators with 48 | | [] -> errors 49 | | validator :: rest -> ( 50 | match validator value with 51 | | Ok _ -> validate rest errors 52 | | Error error -> validate rest (error :: errors)) 53 | in 54 | let errors = validate validators [] in 55 | match errors with [] -> Ok () | errors -> Error (name, errors)) 56 | | None -> Ok () 57 | 58 | let iterable_item index (validators : 'a validator list) item : 59 | (unit, index_validation_error) result = 60 | let rec validate validators errors = 61 | match validators with 62 | | [] -> errors 63 | | validator :: rest -> ( 64 | match validator item with 65 | | Ok _ -> validate rest errors 66 | | Error error -> validate rest (error :: errors)) 67 | in 68 | match validate validators [] with 69 | | [] -> Ok () 70 | | errors -> Error (index, errors) 71 | 72 | let list (validators : 'a validator list) iterable : 73 | (unit, validation_error) result = 74 | let rec validate iterable errors index = 75 | match iterable with 76 | | [] -> errors 77 | | item :: rest -> ( 78 | match iterable_item index validators item with 79 | | Ok _ -> validate rest errors (index + 1) 80 | | Error error -> validate rest (error :: errors) (index + 1)) 81 | in 82 | match validate iterable [] 0 with 83 | | [] -> Ok () 84 | | errors -> Error (IterableError errors) 85 | 86 | let ignore_ok f v = 87 | let result = f v in 88 | match result with Ok _ -> Ok () | Error _ as error -> error 89 | 90 | let group (validators : 'a validator list) value = 91 | let rec validate validators errors = 92 | match validators with 93 | | [] -> errors 94 | | validator :: rest -> ( 95 | match validator value with 96 | | Ok _ -> validate rest errors 97 | | Error error -> validate rest (error :: errors)) 98 | in 99 | match validate validators [] with 100 | | [] -> Ok () 101 | | errors -> Error (GroupError errors) 102 | 103 | let option (validators : 'a validator list) : 'a option validator = function 104 | | Some value -> group validators value 105 | | None -> Ok () 106 | 107 | let ignore_if (condition : bool) (validators : 'a validator list) = 108 | if condition then [] else validators 109 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/variant.ml: -------------------------------------------------------------------------------- 1 | type tuple_variant = 2 | | EmailToId of (string[@email]) * (int[@greater_than_or_equal 0]) 3 | | Email of (string[@email]) 4 | [@@deriving validate, eq, show] 5 | 6 | let tuple_variant_testable = 7 | Alcotest.testable pp_tuple_variant equal_tuple_variant 8 | 9 | let tuple_variant_email_to_id_ok () = 10 | let v = EmailToId ("test@gmail.com", 1) in 11 | Alcotest.( 12 | check (result tuple_variant_testable Error.validation_error_testable)) 13 | "Ok" (Ok v) (validate_tuple_variant v) 14 | 15 | let tuple_variant_email_ok () = 16 | let v = Email "test@gmail.com" in 17 | Alcotest.( 18 | check (result tuple_variant_testable Error.validation_error_testable)) 19 | "Ok" (Ok v) (validate_tuple_variant v) 20 | 21 | let tuple_variant_email_to_id_error () = 22 | let v = EmailToId ("invalid", -1) in 23 | Alcotest.( 24 | check (result tuple_variant_testable Error.validation_error_testable)) 25 | "Error" 26 | (Error 27 | (Validate.KeyedError 28 | [ 29 | ( "EmailToId.1", 30 | [ 31 | Validate.BaseError 32 | { 33 | code = "value_greater_than_or_equal"; 34 | params = [ ("threshold", "0") ]; 35 | }; 36 | ] ); 37 | ( "EmailToId.0", 38 | [ Validate.BaseError { code = "invalid_email"; params = [] } ] ); 39 | ])) 40 | (validate_tuple_variant v) 41 | 42 | let tuple_variant_email_error () = 43 | let v = Email "invalid" in 44 | Alcotest.( 45 | check (result tuple_variant_testable Error.validation_error_testable)) 46 | "Error" 47 | (Error 48 | (Validate.KeyedError 49 | [ 50 | ( "Email.0", 51 | [ Validate.BaseError { code = "invalid_email"; params = [] } ] ); 52 | ])) 53 | (validate_tuple_variant v) 54 | 55 | type record_variant = 56 | | ID of { id : int [@greater_than_or_equal 0] } 57 | | URL of { url : (string[@url]) } 58 | [@@deriving validate, eq, show] 59 | 60 | let record_variant_testable = 61 | Alcotest.testable pp_record_variant equal_record_variant 62 | 63 | let record_variant_id_ok () = 64 | let v = ID { id = 1 } in 65 | Alcotest.( 66 | check (result record_variant_testable Error.validation_error_testable)) 67 | "Ok" (Ok v) 68 | (validate_record_variant v) 69 | 70 | let record_variant_url_ok () = 71 | let v = URL { url = "https://www.google.com" } in 72 | Alcotest.( 73 | check (result record_variant_testable Error.validation_error_testable)) 74 | "Ok" (Ok v) 75 | (validate_record_variant v) 76 | 77 | let record_variant_id_error () = 78 | let v = ID { id = -2137 } in 79 | Alcotest.( 80 | check (result record_variant_testable Error.validation_error_testable)) 81 | "Error" 82 | (Error 83 | (Validate.KeyedError 84 | [ 85 | ( "ID.id", 86 | [ 87 | Validate.BaseError 88 | { 89 | code = "value_greater_than_or_equal"; 90 | params = [ ("threshold", "0") ]; 91 | }; 92 | ] ); 93 | ])) 94 | (validate_record_variant v) 95 | 96 | let record_variant_url_error () = 97 | let v = URL { url = "invalid" } in 98 | Alcotest.( 99 | check (result record_variant_testable Error.validation_error_testable)) 100 | "Error" 101 | (Error 102 | (Validate.KeyedError 103 | [ 104 | ( "URL.url", 105 | [ Validate.BaseError { code = "invalid_url"; params = [] } ] ); 106 | ])) 107 | (validate_record_variant v) 108 | 109 | let t = 110 | let open Alcotest in 111 | ( "variant", 112 | [ 113 | test_case "tuple_variant.EmailToId - Ok" `Quick 114 | tuple_variant_email_to_id_ok; 115 | test_case "tuple_variant.Email - Ok" `Quick tuple_variant_email_ok; 116 | test_case "tuple_variant.EmailToId - Error" `Quick 117 | tuple_variant_email_to_id_error; 118 | test_case "tuple_variant.Email - Error" `Quick tuple_variant_email_error; 119 | test_case "record_variant.ID - Ok" `Quick record_variant_id_ok; 120 | test_case "record_variant.URL - Ok" `Quick record_variant_url_ok; 121 | test_case "record_variant.ID - Error" `Quick record_variant_id_error; 122 | test_case "record_variant.URL - Error" `Quick record_variant_url_error; 123 | ] ) 124 | -------------------------------------------------------------------------------- /ppx_derive_validate/exps.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Ast_helper 3 | open Pats 4 | 5 | let int_exp i = Exp.constant (Pconst_integer (string_of_int i, None)) 6 | let float_exp f = Exp.constant (Pconst_float (string_of_float f, None)) 7 | let string_exp ~loc s = Exp.constant (Pconst_string (s, loc, None)) 8 | let simple_ident_exp ~loc str = Exp.ident { txt = Lident str; loc } 9 | 10 | let apply_exp f args = 11 | let open Exp in 12 | match args with [] -> f | _ -> apply f args 13 | 14 | let module_ident_exp ~loc m str = 15 | Exp.(ident { txt = Ldot (Lident m, str); loc }) 16 | 17 | let rec list_exp ~loc = function 18 | | [] -> Exp.construct { txt = Lident "[]"; loc } None 19 | | x :: xs -> 20 | Exp.construct { txt = Lident "::"; loc } 21 | (Some (Exp.tuple [ x; list_exp ~loc xs ])) 22 | 23 | let validate_func_exp ~loc validator_name params = 24 | let open Exp in 25 | match params with 26 | | [] -> module_ident_exp ~loc "Validate" validator_name 27 | | _ -> apply (module_ident_exp ~loc "Validate" validator_name) params 28 | 29 | let field_extractor_exp ~loc name = 30 | let open Exp in 31 | fun_ Nolabel None 32 | (Pat.var { txt = "x"; loc }) 33 | (field (simple_ident_exp ~loc "x") { txt = Lident name; loc }) 34 | 35 | let validate_list_exp ~loc inner = 36 | let open Exp in 37 | apply (module_ident_exp ~loc "Validate" "list") [ (Nolabel, inner) ] 38 | 39 | let ignore_ok_exp ~loc inner = 40 | let open Exp in 41 | apply (module_ident_exp ~loc "Validate" "ignore_ok") [ (Nolabel, inner) ] 42 | 43 | let dive_exp ~loc type_name = 44 | let open Exp in 45 | let txt = 46 | match type_name with 47 | | Lident name -> Lident (Printf.sprintf "validate_%s" name) 48 | | Ldot (module_name, name) -> 49 | Ldot (module_name, Printf.sprintf "validate_%s" name) 50 | | _ -> Location.raise_errorf ~loc "Something went wrong" 51 | in 52 | 53 | ident { txt; loc } 54 | 55 | let variant_tuple_extractor_exp ~loc expected_type_name total n = 56 | let pattern = n_element_tuple_pat ~loc ~prefix:"x" total in 57 | let match_exp = 58 | Exp.match_ 59 | (simple_ident_exp ~loc "x") 60 | [ 61 | Exp.case 62 | (Pat.construct 63 | { txt = Lident expected_type_name; loc } 64 | (Some pattern)) 65 | (Exp.construct 66 | { txt = Lident "Some"; loc } 67 | (Some (simple_ident_exp ~loc (Printf.sprintf "x%d" n)))); 68 | Exp.case (Pat.any ()) (Exp.construct { txt = Lident "None"; loc } None); 69 | ] 70 | in 71 | Exp.(fun_ Nolabel None (Pat.var { txt = "x"; loc }) match_exp) 72 | 73 | let variant_record_extractor_exp ~loc expected_type_name field_names 74 | extracted_field_name = 75 | let pattern = record_pat ~loc field_names in 76 | let match_exp = 77 | Exp.match_ 78 | (simple_ident_exp ~loc "x") 79 | [ 80 | Exp.case 81 | (Pat.construct 82 | { txt = Lident expected_type_name; loc } 83 | (Some pattern)) 84 | (Exp.construct 85 | { txt = Lident "Some"; loc } 86 | (Some (simple_ident_exp ~loc extracted_field_name))); 87 | Exp.case (Pat.any ()) (Exp.construct { txt = Lident "None"; loc } None); 88 | ] 89 | in 90 | Exp.(fun_ Nolabel None (Pat.var { txt = "x"; loc }) match_exp) 91 | 92 | let validate_field_exp ~loc name extractor_fun_exp validators_list_exp = 93 | Exp.( 94 | apply 95 | (module_ident_exp ~loc "Validate" "field") 96 | [ 97 | (Nolabel, string_exp ~loc name); 98 | (Nolabel, extractor_fun_exp); 99 | (Nolabel, validators_list_exp); 100 | ]) 101 | 102 | let validate_named_value_exp ~loc name extractor_fun_exp validators_list_exp = 103 | Exp.( 104 | apply 105 | (module_ident_exp ~loc "Validate" "named_value") 106 | [ 107 | (Nolabel, string_exp ~loc name); 108 | (Nolabel, extractor_fun_exp); 109 | (Nolabel, validators_list_exp); 110 | ]) 111 | 112 | let tuple_element_extractor_fun_exp ~loc total n = 113 | let open Exp in 114 | let pattern = n_element_tuple_pat ~loc ~prefix:"x" total in 115 | fun_ Nolabel None pattern (simple_ident_exp ~loc (Printf.sprintf "x%d" n)) 116 | 117 | let validate_keyed_exp ~loc arg_exp = 118 | Exp.(apply (module_ident_exp ~loc "Validate" "keyed") [ (Nolabel, arg_exp) ]) 119 | 120 | let validate_group_exp ~loc arg_exp = 121 | Exp.(apply (module_ident_exp ~loc "Validate" "group") [ (Nolabel, arg_exp) ]) 122 | 123 | let validate_exp ~loc arg_exp = 124 | Exp.( 125 | apply 126 | (module_ident_exp ~loc "Validate" "validate") 127 | [ (Nolabel, arg_exp); (Nolabel, simple_ident_exp ~loc "x") ]) 128 | 129 | let validate_option ~loc arg_exp = 130 | Exp.(apply (module_ident_exp ~loc "Validate" "option") [ (Nolabel, arg_exp) ]) 131 | 132 | let ignore_if_func_exp ~loc (cond_exp : expression option) inner_exp = 133 | let open Exp in 134 | match cond_exp with 135 | | None -> inner_exp 136 | | Some cond_exp -> 137 | let cond_result_exp = 138 | apply cond_exp [ (Nolabel, simple_ident_exp ~loc "x") ] 139 | in 140 | apply 141 | (module_ident_exp ~loc "Validate" "ignore_if") 142 | [ (Nolabel, cond_result_exp); (Nolabel, inner_exp) ] 143 | -------------------------------------------------------------------------------- /validate_test/regex.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let test_validate_uuid () = 4 | let uuid = "f47ac10b-58cc-4372-a567-0e02b2c3d479" in 5 | let result = Validate.validate_uuid uuid in 6 | 7 | Alcotest.(check (result unit validation_error_testable)) 8 | "returns Ok" (Ok ()) result 9 | 10 | let test_validate_uuid_invalid () = 11 | let uuid = "f47ac10b-58cc-4372-a567-0e02b2c3d4791" in 12 | let result = Validate.validate_uuid uuid in 13 | 14 | Alcotest.(check (result unit validation_error_testable)) 15 | "returns Error" 16 | (Error 17 | (Validate.BaseError 18 | { code = Validate.invalid_uuid_error_code; params = [] })) 19 | result 20 | 21 | let uuid = 22 | let open Alcotest in 23 | ( "validate_uuid", 24 | [ 25 | test_case "Valid uuid" `Quick test_validate_uuid; 26 | test_case "Invalid uuid" `Quick test_validate_uuid_invalid; 27 | ] ) 28 | 29 | let test_validate_ulid () = 30 | let ulid = "01D3XZ1ZQZQZQZQZQZQZQZQZQZ" in 31 | let result = Validate.validate_ulid ulid in 32 | 33 | Alcotest.(check (result unit validation_error_testable)) 34 | "returns Ok" (Ok ()) result 35 | 36 | let test_validate_ulid_invalid () = 37 | let ulid = "01D3XZ1ZQZQZQZQZQZQZQZQZQZ1" in 38 | let result = Validate.validate_ulid ulid in 39 | 40 | Alcotest.(check (result unit validation_error_testable)) 41 | "returns Error" 42 | (Error 43 | (Validate.BaseError 44 | { code = Validate.invalid_ulid_error_code; params = [] })) 45 | result 46 | 47 | let ulid = 48 | let open Alcotest in 49 | ( "validate_ulid", 50 | [ 51 | test_case "Valid ulid" `Quick test_validate_ulid; 52 | test_case "Invalid ulid" `Quick test_validate_ulid_invalid; 53 | ] ) 54 | 55 | let test_validate_ipv4 () = 56 | let ipv4 = "192.168.0.1" in 57 | let result = Validate.validate_ipv4 ipv4 in 58 | Alcotest.(check (result unit validation_error_testable)) 59 | "returns Ok" (Ok ()) result 60 | 61 | let test_validate_ipv4_invalid () = 62 | let ipv4 = "192.168.0.256" in 63 | let result = Validate.validate_ipv4 ipv4 in 64 | 65 | Alcotest.(check (result unit validation_error_testable)) 66 | "returns Error" 67 | (Error 68 | (Validate.BaseError 69 | { code = Validate.invalid_ipv4_error_code; params = [] })) 70 | result 71 | 72 | let ipv4 = 73 | let open Alcotest in 74 | ( "validate_ipv4", 75 | [ 76 | test_case "Valid ipv4" `Quick test_validate_ipv4; 77 | test_case "Invalid ipv4" `Quick test_validate_ipv4_invalid; 78 | ] ) 79 | 80 | let test_validate_ipv6 () = 81 | let ipv6 = "2001:0db8:85a3:0000:0000:8a2e:0370:7334" in 82 | let result = Validate.validate_ipv6 ipv6 in 83 | Alcotest.(check (result unit validation_error_testable)) 84 | "returns Ok" (Ok ()) result 85 | 86 | let test_validate_ipv6_invalid () = 87 | let ipv6 = "2001:0db8:85a3:0000:0000:8a2e:0370:7334:1" in 88 | let result = Validate.validate_ipv6 ipv6 in 89 | Alcotest.(check (result unit validation_error_testable)) 90 | "returns Error" 91 | (Error 92 | (Validate.BaseError 93 | { code = Validate.invalid_ipv6_error_code; params = [] })) 94 | result 95 | 96 | let ipv6 = 97 | let open Alcotest in 98 | ( "validate_ipv6", 99 | [ 100 | test_case "Valid ipv6" `Quick test_validate_ipv6; 101 | test_case "Invalid ipv6" `Quick test_validate_ipv6_invalid; 102 | ] ) 103 | 104 | let test_validate_phone_number () = 105 | let phone_number = "+15417543010" in 106 | let result = Validate.validate_phone_number phone_number in 107 | Alcotest.(check (result unit validation_error_testable)) 108 | "returns Ok" (Ok ()) result 109 | 110 | let test_validate_phone_number_invalid () = 111 | let phone_number = "+15-4175430101" in 112 | let result = Validate.validate_phone_number phone_number in 113 | Alcotest.(check (result unit validation_error_testable)) 114 | "returns Error" 115 | (Error 116 | (Validate.BaseError 117 | { code = Validate.invalid_phone_number_error_code; params = [] })) 118 | result 119 | 120 | let phone_number = 121 | let open Alcotest in 122 | ( "validate_phone_number", 123 | [ 124 | test_case "Valid phone_number" `Quick test_validate_phone_number; 125 | test_case "Invalid phone_number" `Quick test_validate_phone_number_invalid; 126 | ] ) 127 | 128 | let test_validate_mac_address () = 129 | let mac_address = "00:00:00:00:00:00" in 130 | let result = Validate.validate_mac_address mac_address in 131 | Alcotest.(check (result unit validation_error_testable)) 132 | "returns Ok" (Ok ()) result 133 | 134 | let test_validate_mac_address_invalid () = 135 | let mac_address = "00:00:00:00:00:00:00" in 136 | let result = Validate.validate_mac_address mac_address in 137 | Alcotest.(check (result unit validation_error_testable)) 138 | "returns Error" 139 | (Error 140 | (Validate.BaseError 141 | { code = Validate.invalid_mac_address_error_code; params = [] })) 142 | result 143 | 144 | let mac_address = 145 | let open Alcotest in 146 | ( "validate_mac_address", 147 | [ 148 | test_case "Valid mac_address" `Quick test_validate_mac_address; 149 | test_case "Invalid mac_address" `Quick test_validate_mac_address_invalid; 150 | ] ) 151 | 152 | let t = [ uuid; ulid; ipv4; ipv6; phone_number; mac_address ] 153 | -------------------------------------------------------------------------------- /validate_test/length.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | let test_validate_string_min_length_long () = 4 | let min_length = 5 in 5 | let string = "123456" in 6 | let result = Validate.validate_min_length String.length min_length string in 7 | 8 | Alcotest.(check (result unit validation_error_testable)) 9 | "returns Ok" (Ok ()) result 10 | 11 | let test_validate_list_min_length_long () = 12 | let min_length = 5 in 13 | let list = [ 1; 2; 3; 4; 5 ] in 14 | let result = Validate.validate_min_length List.length min_length list in 15 | 16 | Alcotest.(check (result unit validation_error_testable)) 17 | "returns Ok" (Ok ()) result 18 | 19 | let test_validate_string_min_length_short () = 20 | let min_length = 5 in 21 | let string = "1234" in 22 | let result = Validate.validate_min_length String.length min_length string in 23 | 24 | Alcotest.(check (result unit validation_error_testable)) 25 | "returns Error" 26 | (Error 27 | (Validate.BaseError 28 | { 29 | code = Validate.min_length_error_code; 30 | params = [ ("threshold", string_of_int min_length) ]; 31 | })) 32 | result 33 | 34 | let test_validate_list_min_length_short () = 35 | let min_length = 5 in 36 | let list = [ 1; 2; 3; 4 ] in 37 | let result = Validate.validate_min_length List.length min_length list in 38 | 39 | Alcotest.(check (result unit validation_error_testable)) 40 | "returns Error" 41 | (Error 42 | (Validate.BaseError 43 | { 44 | code = Validate.min_length_error_code; 45 | params = [ ("threshold", string_of_int min_length) ]; 46 | })) 47 | result 48 | 49 | let min_string_length = 50 | let open Alcotest in 51 | ( "validate_min_length", 52 | [ 53 | test_case "Long enough string" `Quick test_validate_string_min_length_long; 54 | test_case "Too short string" `Quick test_validate_string_min_length_short; 55 | test_case "Long enough list" `Quick test_validate_list_min_length_long; 56 | test_case "Too short list" `Quick test_validate_list_min_length_short; 57 | ] ) 58 | 59 | let test_validate_string_max_length_long () = 60 | let max_length = 5 in 61 | let string = "123456" in 62 | let result = Validate.validate_max_length String.length max_length string in 63 | 64 | Alcotest.(check (result unit validation_error_testable)) 65 | "returns Error" 66 | (Error 67 | (Validate.BaseError 68 | { 69 | code = Validate.max_length_error_code; 70 | params = [ ("threshold", string_of_int max_length) ]; 71 | })) 72 | result 73 | 74 | let test_validate_string_max_length_short () = 75 | let max_length = 5 in 76 | let string = "1234" in 77 | let result = Validate.validate_max_length String.length max_length string in 78 | 79 | Alcotest.(check (result unit validation_error_testable)) 80 | "returns Ok" (Ok ()) result 81 | 82 | let test_validate_list_max_length_zero () = 83 | let max_length = 0 in 84 | let list = [] in 85 | let result = Validate.validate_max_length List.length max_length list in 86 | 87 | Alcotest.(check (result unit validation_error_testable)) 88 | "returns Ok" (Ok ()) result 89 | 90 | let max_string_length = 91 | let open Alcotest in 92 | ( "validate_max_length", 93 | [ 94 | test_case "Long enough string" `Quick test_validate_string_max_length_long; 95 | test_case "Too short string" `Quick test_validate_string_max_length_short; 96 | test_case "Zero length list" `Quick test_validate_list_max_length_zero; 97 | ] ) 98 | 99 | let test_validate_string_length_between_long () = 100 | let min = 5 in 101 | let max = 7 in 102 | let string = "1234567890" in 103 | let result = 104 | Validate.validate_length_between String.length ~min ~max string 105 | in 106 | 107 | Alcotest.(check (result unit validation_error_testable)) 108 | "returns Error" 109 | (Error 110 | (Validate.BaseError 111 | { 112 | code = Validate.max_length_error_code; 113 | params = [ ("threshold", string_of_int max) ]; 114 | })) 115 | result 116 | 117 | let test_validate_string_length_between_short () = 118 | let min = 5 in 119 | let max = 7 in 120 | let string = "1234" in 121 | let result = 122 | Validate.validate_length_between String.length ~min ~max string 123 | in 124 | 125 | Alcotest.(check (result unit validation_error_testable)) 126 | "returns Error" 127 | (Error 128 | (Validate.BaseError 129 | { 130 | code = Validate.min_length_error_code; 131 | params = [ ("threshold", string_of_int min) ]; 132 | })) 133 | result 134 | 135 | let test_validate_string_length_between_ok () = 136 | let min = 5 in 137 | let max = 7 in 138 | let string = "123456" in 139 | let result = 140 | Validate.validate_length_between String.length ~min ~max string 141 | in 142 | 143 | Alcotest.(check (result unit validation_error_testable)) 144 | "returns Ok" (Ok ()) result 145 | 146 | let length_between = 147 | let open Alcotest in 148 | ( "validate_length_between", 149 | [ 150 | test_case "String too long" `Quick 151 | test_validate_string_length_between_long; 152 | test_case "String too short" `Quick 153 | test_validate_string_length_between_short; 154 | test_case "String ok" `Quick test_validate_string_length_between_ok; 155 | ] ) 156 | 157 | let test_validate_string_length_equals_long () = 158 | let length = 5 in 159 | let string = "123456" in 160 | let result = Validate.validate_length_equals String.length length string in 161 | 162 | Alcotest.(check (result unit validation_error_testable)) 163 | "returns Error" 164 | (Error 165 | (Validate.BaseError 166 | { 167 | code = Validate.length_equals_error_code; 168 | params = [ ("value", string_of_int length) ]; 169 | })) 170 | result 171 | 172 | let test_validate_string_length_equals_ok () = 173 | let length = 5 in 174 | let string = "12345" in 175 | let result = Validate.validate_length_equals String.length length string in 176 | 177 | Alcotest.(check (result unit validation_error_testable)) 178 | "returns Ok" (Ok ()) result 179 | 180 | let lenght_equals_string = 181 | let open Alcotest in 182 | ( "validate_length_equals", 183 | [ 184 | test_case "String too long" `Quick test_validate_string_length_equals_long; 185 | test_case "String ok" `Quick test_validate_string_length_equals_ok; 186 | ] ) 187 | 188 | let t = 189 | [ min_string_length; max_string_length; length_between; lenght_equals_string ] 190 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/conditional.ml: -------------------------------------------------------------------------------- 1 | type cond_record = { 2 | unit : string; 3 | temperature : int; 4 | [@greater_than_or_equal 0] [@ignore_if fun r -> r.unit <> "K"] 5 | } 6 | [@@deriving validate, eq, show] 7 | 8 | let cond_record_testable = Alcotest.testable pp_cond_record equal_cond_record 9 | 10 | let test_cond_record_k_ok () = 11 | let r = { unit = "K"; temperature = 0 } in 12 | let result = validate_cond_record r in 13 | 14 | Alcotest.(check (result cond_record_testable Error.validation_error_testable)) 15 | "Ok" (Ok r) result 16 | 17 | let test_cond_record_k_err () = 18 | let r = { unit = "K"; temperature = -10 } in 19 | let result = validate_cond_record r in 20 | 21 | Alcotest.(check (result cond_record_testable Error.validation_error_testable)) 22 | "Error" 23 | (Error 24 | (Validate.KeyedError 25 | [ 26 | ( "temperature", 27 | [ 28 | Validate.BaseError 29 | { 30 | code = "value_greater_than_or_equal"; 31 | params = [ ("threshold", "0") ]; 32 | }; 33 | ] ); 34 | ])) 35 | result 36 | 37 | let test_cond_record_c_ok () = 38 | let r = { unit = "C"; temperature = -10 } in 39 | let result = validate_cond_record r in 40 | 41 | Alcotest.(check (result cond_record_testable Error.validation_error_testable)) 42 | "Ok" (Ok r) result 43 | 44 | type cond_tuple = 45 | string * (int[@greater_than_or_equal 0] [@ignore_if fun (u, _) -> u <> "K"]) 46 | [@@deriving validate, eq, show] 47 | 48 | let cond_tuple_testable = Alcotest.testable pp_cond_tuple equal_cond_tuple 49 | 50 | let test_cond_tuple_k_ok () = 51 | let r = ("K", 0) in 52 | let result = validate_cond_tuple r in 53 | 54 | Alcotest.(check (result cond_tuple_testable Error.validation_error_testable)) 55 | "Ok" (Ok r) result 56 | 57 | let test_cond_tuple_k_err () = 58 | let r = ("K", -10) in 59 | let result = validate_cond_tuple r in 60 | 61 | Alcotest.(check (result cond_tuple_testable Error.validation_error_testable)) 62 | "Error" 63 | (Error 64 | (Validate.GroupError 65 | [ 66 | Validate.KeyedError 67 | [ 68 | ( "1", 69 | [ 70 | Validate.BaseError 71 | { 72 | code = "value_greater_than_or_equal"; 73 | params = [ ("threshold", "0") ]; 74 | }; 75 | ] ); 76 | ]; 77 | ])) 78 | result 79 | 80 | let test_cond_tuple_c_ok () = 81 | let r = ("C", -10) in 82 | let result = validate_cond_tuple r in 83 | 84 | Alcotest.(check (result cond_tuple_testable Error.validation_error_testable)) 85 | "Ok" (Ok r) result 86 | 87 | type cond_variant = 88 | | Tuple of 89 | string 90 | * (int 91 | [@greater_than_or_equal 0] 92 | [@ignore_if 93 | fun v -> match v with Tuple (u, _) -> u <> "K" | _ -> false]) 94 | | Record of { 95 | unit : string; 96 | temperature : int; 97 | [@greater_than_or_equal 0] 98 | [@ignore_if 99 | fun v -> match v with Record r -> r.unit <> "K" | _ -> false] 100 | } 101 | [@@deriving validate, eq, show] 102 | 103 | let cond_variant_testable = Alcotest.testable pp_cond_variant equal_cond_variant 104 | 105 | let test_cond_variant_tuple_k_ok () = 106 | let r = Tuple ("K", 0) in 107 | let result = validate_cond_variant r in 108 | 109 | Alcotest.( 110 | check (result cond_variant_testable Error.validation_error_testable)) 111 | "Ok" (Ok r) result 112 | 113 | let test_cond_variant_tuple_k_err () = 114 | let r = Tuple ("K", -10) in 115 | let result = validate_cond_variant r in 116 | 117 | Alcotest.( 118 | check (result cond_variant_testable Error.validation_error_testable)) 119 | "Error" 120 | (Error 121 | (Validate.KeyedError 122 | [ 123 | ( "Tuple.1", 124 | [ 125 | Validate.BaseError 126 | { 127 | code = "value_greater_than_or_equal"; 128 | params = [ ("threshold", "0") ]; 129 | }; 130 | ] ); 131 | ])) 132 | result 133 | 134 | let test_cond_variant_tuple_c_ok () = 135 | let r = Tuple ("C", -10) in 136 | let result = validate_cond_variant r in 137 | 138 | Alcotest.( 139 | check (result cond_variant_testable Error.validation_error_testable)) 140 | "Ok" (Ok r) result 141 | 142 | let test_cond_variant_record_k_ok () = 143 | let r = Record { unit = "K"; temperature = 0 } in 144 | let result = validate_cond_variant r in 145 | 146 | Alcotest.( 147 | check (result cond_variant_testable Error.validation_error_testable)) 148 | "Ok" (Ok r) result 149 | 150 | let test_cond_variant_record_k_err () = 151 | let r = Record { unit = "K"; temperature = -10 } in 152 | let result = validate_cond_variant r in 153 | 154 | Alcotest.( 155 | check (result cond_variant_testable Error.validation_error_testable)) 156 | "Error" 157 | (Error 158 | (Validate.KeyedError 159 | [ 160 | ( "Record.temperature", 161 | [ 162 | Validate.BaseError 163 | { 164 | code = "value_greater_than_or_equal"; 165 | params = [ ("threshold", "0") ]; 166 | }; 167 | ] ); 168 | ])) 169 | result 170 | 171 | let test_cond_variant_record_c_ok () = 172 | let r = Record { unit = "C"; temperature = -10 } in 173 | let result = validate_cond_variant r in 174 | 175 | Alcotest.( 176 | check (result cond_variant_testable Error.validation_error_testable)) 177 | "Ok" (Ok r) result 178 | 179 | type username_or_email = { 180 | username : string option; [@some_if fun r -> r.email = None] 181 | email : string option; [@none_if fun r -> Option.is_some r.username] 182 | } 183 | [@@deriving validate, eq, show] 184 | 185 | let username_or_email_testable = 186 | Alcotest.testable pp_username_or_email equal_username_or_email 187 | 188 | let test_username_or_email_username_ok () = 189 | let r = { username = Some "username"; email = None } in 190 | let result = validate_username_or_email r in 191 | 192 | Alcotest.( 193 | check (result username_or_email_testable Error.validation_error_testable)) 194 | "Ok" (Ok r) result 195 | 196 | let test_username_or_email_email_ok () = 197 | let r = { username = None; email = Some "email" } in 198 | let result = validate_username_or_email r in 199 | 200 | Alcotest.( 201 | check (result username_or_email_testable Error.validation_error_testable)) 202 | "Ok" (Ok r) result 203 | 204 | let test_username_or_email_both_err () = 205 | let r = { username = Some "username"; email = Some "email" } in 206 | let result = validate_username_or_email r in 207 | 208 | Alcotest.( 209 | check (result username_or_email_testable Error.validation_error_testable)) 210 | "Error" 211 | (Error 212 | (Validate.KeyedError 213 | [ 214 | ( "email", 215 | [ Validate.BaseError { code = "expect_none"; params = [] } ] ); 216 | ( "username", 217 | [ Validate.BaseError { code = "expect_none"; params = [] } ] ); 218 | ])) 219 | result 220 | 221 | let test_username_or_email_both_none () = 222 | let r = { username = None; email = None } in 223 | let result = validate_username_or_email r in 224 | 225 | Alcotest.( 226 | check (result username_or_email_testable Error.validation_error_testable)) 227 | "Error" 228 | (Error 229 | (Validate.KeyedError 230 | [ 231 | ( "email", 232 | [ Validate.BaseError { code = "expect_some"; params = [] } ] ); 233 | ( "username", 234 | [ Validate.BaseError { code = "expect_some"; params = [] } ] ); 235 | ])) 236 | result 237 | 238 | let t = 239 | let open Alcotest in 240 | ( "conditinal", 241 | [ 242 | test_case "cond_record - K - Ok" `Quick test_cond_record_k_ok; 243 | test_case "cond_record - K - Error" `Quick test_cond_record_k_err; 244 | test_case "cond_record - C - Ok" `Quick test_cond_record_c_ok; 245 | test_case "cond_tuple - K - Ok" `Quick test_cond_tuple_k_ok; 246 | test_case "cond_tuple - K - Error" `Quick test_cond_tuple_k_err; 247 | test_case "cond_tuple - C - Ok" `Quick test_cond_tuple_c_ok; 248 | test_case "cond_variant - Tuple - K - Ok" `Quick 249 | test_cond_variant_tuple_k_ok; 250 | test_case "cond_variant - Tuple - K - Error" `Quick 251 | test_cond_variant_tuple_k_err; 252 | test_case "cond_variant - Tuple - C - Ok" `Quick 253 | test_cond_variant_tuple_c_ok; 254 | test_case "cond_variant - Record - K - Ok" `Quick 255 | test_cond_variant_record_k_ok; 256 | test_case "cond_variant - Record - K - Error" `Quick 257 | test_cond_variant_record_k_err; 258 | test_case "cond_variant - Record - C - Ok" `Quick 259 | test_cond_variant_record_c_ok; 260 | test_case "username_or_email - username - Ok" `Quick 261 | test_username_or_email_username_ok; 262 | test_case "username_or_email - email - Ok" `Quick 263 | test_username_or_email_email_ok; 264 | test_case "username_or_email - both - Error" `Quick 265 | test_username_or_email_both_err; 266 | test_case "username_or_email - both - None" `Quick 267 | test_username_or_email_both_none; 268 | ] ) 269 | -------------------------------------------------------------------------------- /validate_test/helper.ml: -------------------------------------------------------------------------------- 1 | open Err 2 | 3 | type test_record = { a : string; b : string; c : string } 4 | 5 | let test_validate_record_error_simple () = 6 | let r = { a = "111"; b = "333"; c = "" } in 7 | let validate = 8 | Validate.( 9 | keyed 10 | [ 11 | field "a" 12 | (fun x -> x.a) 13 | [ validate_length_between String.length ~min:1 ~max:2 ]; 14 | field "b" (fun x -> x.b) [ validate_min_length String.length 1 ]; 15 | field "c" (fun x -> x.c) [ validate_min_length String.length 1 ]; 16 | ]) 17 | in 18 | let result = validate r in 19 | 20 | Alcotest.(check (result unit validation_error_testable)) 21 | "validate record" 22 | (Error 23 | (Validate.KeyedError 24 | [ 25 | ( "c", 26 | [ 27 | Validate.BaseError 28 | { code = "min_length"; params = [ ("threshold", "1") ] }; 29 | ] ); 30 | ( "a", 31 | [ 32 | Validate.BaseError 33 | { code = "max_length"; params = [ ("threshold", "2") ] }; 34 | ] ); 35 | ])) 36 | result 37 | 38 | let test_validate_record_ok_simple () = 39 | let r = { a = "111"; b = "333"; c = "444" } in 40 | let validate = 41 | Validate.( 42 | keyed 43 | [ 44 | field "a" 45 | (fun x -> x.a) 46 | [ validate_length_between String.length ~min:1 ~max:3 ]; 47 | field "b" (fun x -> x.b) [ validate_min_length String.length 1 ]; 48 | field "c" (fun x -> x.c) [ validate_min_length String.length 1 ]; 49 | ]) 50 | in 51 | 52 | let result = validate r in 53 | 54 | Alcotest.(check (result unit validation_error_testable)) 55 | "validate record" (Ok ()) result 56 | 57 | type complex_record = { 58 | x1 : string; 59 | x2 : complex_record_nested; 60 | x3 : complex_record_nested list; 61 | } 62 | 63 | and complex_record_nested = { y1 : string; y2 : string } 64 | 65 | let test_validate_record_error_complex () = 66 | let r = 67 | { 68 | x1 = "111"; 69 | x2 = { y1 = "111"; y2 = "222" }; 70 | x3 = [ { y1 = "1"; y2 = "222" }; { y1 = "111"; y2 = "22222" } ]; 71 | } 72 | in 73 | let validate = 74 | Validate.( 75 | keyed 76 | [ 77 | field "x1" 78 | (fun x -> x.x1) 79 | [ validate_length_between String.length ~min:1 ~max:2 ]; 80 | field "x2" 81 | (fun x -> x.x2) 82 | [ 83 | keyed 84 | [ 85 | field "y1" 86 | (fun x -> x.y1) 87 | [ validate_length_between String.length ~min:1 ~max:2 ]; 88 | field "y2" 89 | (fun x -> x.y2) 90 | [ validate_length_between String.length ~min:1 ~max:2 ]; 91 | ]; 92 | ]; 93 | field "x3" 94 | (fun x -> x.x3) 95 | [ 96 | list 97 | [ 98 | keyed 99 | [ 100 | field "y1" 101 | (fun x -> x.y1) 102 | [ validate_length_between String.length ~min:1 ~max:2 ]; 103 | field "y2" 104 | (fun x -> x.y2) 105 | [ validate_length_between String.length ~min:1 ~max:2 ]; 106 | ]; 107 | ]; 108 | ]; 109 | ]) 110 | in 111 | let result = validate r in 112 | 113 | Alcotest.(check (result unit validation_error_testable)) 114 | "validate record" 115 | (Error 116 | (Validate.KeyedError 117 | [ 118 | ( "x3", 119 | [ 120 | Validate.IterableError 121 | [ 122 | ( 1, 123 | [ 124 | Validate.KeyedError 125 | [ 126 | ( "y2", 127 | [ 128 | Validate.BaseError 129 | { 130 | code = "max_length"; 131 | params = [ ("threshold", "2") ]; 132 | }; 133 | ] ); 134 | ( "y1", 135 | [ 136 | Validate.BaseError 137 | { 138 | code = "max_length"; 139 | params = [ ("threshold", "2") ]; 140 | }; 141 | ] ); 142 | ]; 143 | ] ); 144 | ( 0, 145 | [ 146 | Validate.KeyedError 147 | [ 148 | ( "y2", 149 | [ 150 | Validate.BaseError 151 | { 152 | code = "max_length"; 153 | params = [ ("threshold", "2") ]; 154 | }; 155 | ] ); 156 | ]; 157 | ] ); 158 | ]; 159 | ] ); 160 | ( "x2", 161 | [ 162 | Validate.KeyedError 163 | [ 164 | ( "y2", 165 | [ 166 | Validate.BaseError 167 | { 168 | code = "max_length"; 169 | params = [ ("threshold", "2") ]; 170 | }; 171 | ] ); 172 | ( "y1", 173 | [ 174 | Validate.BaseError 175 | { 176 | code = "max_length"; 177 | params = [ ("threshold", "2") ]; 178 | }; 179 | ] ); 180 | ]; 181 | ] ); 182 | ( "x1", 183 | [ 184 | Validate.BaseError 185 | { code = "max_length"; params = [ ("threshold", "2") ] }; 186 | ] ); 187 | ])) 188 | result 189 | 190 | let test_validate_record_ok_complex () = 191 | let r = 192 | { 193 | x1 = "111"; 194 | x2 = { y1 = "111"; y2 = "222" }; 195 | x3 = [ { y1 = "1"; y2 = "2" }; { y1 = "11"; y2 = "22" } ]; 196 | } 197 | in 198 | let validate = 199 | Validate.( 200 | keyed 201 | [ 202 | field "x1" 203 | (fun x -> x.x1) 204 | [ validate_length_between String.length ~min:1 ~max:3 ]; 205 | field "x2" 206 | (fun x -> x.x2) 207 | [ 208 | keyed 209 | [ 210 | field "y1" 211 | (fun x -> x.y1) 212 | [ validate_length_between String.length ~min:1 ~max:3 ]; 213 | field "y2" 214 | (fun x -> x.y2) 215 | [ validate_length_between String.length ~min:1 ~max:3 ]; 216 | ]; 217 | ]; 218 | field "x3" 219 | (fun x -> x.x3) 220 | [ 221 | list 222 | [ 223 | keyed 224 | [ 225 | field "y1" 226 | (fun x -> x.y1) 227 | [ validate_length_between String.length ~min:1 ~max:3 ]; 228 | field "y2" 229 | (fun x -> x.y2) 230 | [ validate_length_between String.length ~min:1 ~max:3 ]; 231 | ]; 232 | ]; 233 | ]; 234 | ]) 235 | in 236 | let result = validate r in 237 | 238 | Alcotest.(check (result unit validation_error_testable)) 239 | "validate record" (Ok ()) result 240 | 241 | let test_validate_list_error () = 242 | let r = [ "111"; "3"; "" ] in 243 | let validate = 244 | Validate.(list [ validate_length_between String.length ~min:1 ~max:2 ]) 245 | in 246 | let result = validate r in 247 | 248 | Alcotest.(check (result unit validation_error_testable)) 249 | "validate list" 250 | (Error 251 | (Validate.IterableError 252 | [ 253 | ( 2, 254 | [ 255 | Validate.BaseError 256 | { code = "min_length"; params = [ ("threshold", "1") ] }; 257 | ] ); 258 | ( 0, 259 | [ 260 | Validate.BaseError 261 | { code = "max_length"; params = [ ("threshold", "2") ] }; 262 | ] ); 263 | ])) 264 | result 265 | 266 | let test_validate_list_ok () = 267 | let r = [ "111"; "333"; "444" ] in 268 | let validate = 269 | Validate.( 270 | list 271 | [ 272 | validate_length_between String.length ~min:1 ~max:3; 273 | validate_min_length String.length 1; 274 | ]) 275 | in 276 | let result = validate r in 277 | 278 | Alcotest.(check (result unit validation_error_testable)) 279 | "validate list" (Ok ()) result 280 | 281 | let validate_record = 282 | let open Alcotest in 283 | ( "validate_record", 284 | [ 285 | test_case "Error in simple record" `Quick 286 | test_validate_record_error_simple; 287 | test_case "Ok in simple record" `Quick test_validate_record_ok_simple; 288 | test_case "Error in complex record" `Quick 289 | test_validate_record_error_complex; 290 | test_case "Ok in complex record" `Quick test_validate_record_ok_complex; 291 | ] ) 292 | 293 | let validate_list = 294 | let open Alcotest in 295 | ( "validate_list", 296 | [ 297 | test_case "Error in list" `Quick test_validate_list_error; 298 | test_case "Ok in list" `Quick test_validate_list_ok; 299 | ] ) 300 | 301 | let t = [ validate_record; validate_list ] 302 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Validate 2 | 3 | [![codecov](https://codecov.io/gh/Axot017/validate/graph/badge.svg?token=6RF8IIBDNN)](https://codecov.io/gh/Axot017/validate) 4 | [![GitHub Actions Workflow Status](https://img.shields.io/github/actions/workflow/status/Axot017/validate/test.yml)](https://github.com/Axot017/validate/actions/workflows/test.yml) 5 | [![GitHub Release](https://img.shields.io/github/v/release/Axot017/validate)](https://github.com/Axot017/validate/releases) 6 | [![GitHub License](https://img.shields.io/github/license/Axot017/validate)](https://github.com/Axot017/validate/blob/master/LICENSE) 7 | 8 | ## Overview 9 | `validate` is an OCaml library designed to streamline the process of validating records, lists, 10 | or values. It primarily operates through a PPX deriver that automatically generates 11 | validators using annotations, utilizing an underlying library of helper validation functions. 12 | 13 | ## Prerequisites 14 | 15 | - OCaml version 5.0 or higher. 16 | 17 | ## Installation 18 | 19 | ### Installing `validate` 20 | To install the `validate` library, use OPAM with the following command: 21 | ``` 22 | opam install validate 23 | ``` 24 | 25 | After installation, you need to add `validate` as a library in your project's dune file and specify `validate.ppx_derive_validate` as a preprocessor. 26 | Here is an example of how to set up the dune file: 27 | 28 | ```lisp 29 | (library 30 | (name something) 31 | (preprocess (pps validate.ppx_derive_validate)) 32 | (libraries validate)) 33 | ``` 34 | 35 | ## Annotations and Usage 36 | 37 | The `validate` library in OCaml allows for precise validation of data through a variety of annotations. 38 | For each type, the library generates a function named `validate_[type_name]` which can be used to perform the validation. 39 | 40 | ### Example Usage 41 | 42 | #### Validating record 43 | ```ocaml 44 | type test_record = { 45 | min : string; [@min_length 2] 46 | max : string; [@max_length 5] 47 | numeric_list : (int [@less_than 10]) list; [@min_length 2] 48 | ... 49 | } 50 | [@@deriving validate, show, eq] 51 | 52 | let example_record = { min = "ab"; max = "hello"; numeric_list = [1, 2, 3] } 53 | let validation_result = validate_test_record example_record 54 | ``` 55 | 56 | In this example: 57 | 58 | - `min` is a string field validated for a minimum length of 2. 59 | - `max` is validated for a maximum length of 5. 60 | - `numeric_list` is an integer list, validated for a minimum length of 2, and each element is validated to be less than 10. 61 | 62 | #### Validating simple types 63 | ```ocaml 64 | type list_type = ((string[@min_length 1]) list[@min_length 2]) [@@deriving validate] 65 | 66 | let example_list = ["a"; "bc"] 67 | let validation_result = validate_list_type example_list 68 | ``` 69 | In this example, validate_list_type function will validate that each string in the list has a minimum length of 1 and that the list itself has a minimum length of 2. 70 | 71 | #### Validating tuples 72 | ```ocaml 73 | type tuple_type = (string[@email]) * (int[@greater_than 1]) [@@deriving validate] 74 | 75 | let example_tuple = ("example@email.com", 2) 76 | let validation_result = validate_tuple_type example_tuple 77 | ``` 78 | Here, the validate_tuple_type function ensures the first element of the tuple is a valid email address and the second element is an integer greater than 1. 79 | 80 | #### Validating variants 81 | Variants in OCaml can also be validated using `validate`. Here's an example of how to use annotations with variants: 82 | ```ocaml 83 | type tuple_variant = 84 | | EmailToId of (string[@email]) * (int[@greater_than_or_equal 0]) 85 | | Email of (string[@email]) 86 | | Profile of { 87 | username : string [@min_length 3]; 88 | email : string [@email]; 89 | } 90 | [@@deriving validate] 91 | 92 | (* Example usage *) 93 | let email_to_id_variant = EmailToId ("example@email.com", 0) 94 | let validation_result = validate_tuple_variant email_to_id_variant 95 | ``` 96 | In this example: 97 | 98 | - `EmailToId` is a variant that takes a tuple. The first element is validated as an email, and the second as an integer greater than or equal to 0. 99 | - `Email` is a single-element variant validated as an email. 100 | - `Profile` is a record variant with `username` validated for a minimum length of 3, and `email` validated as a valid email address. 101 | 102 | #### Validating Recursive Types 103 | `validate` also supports recursive types, allowing for the validation of nested, self-referential data structures. Here is an example demonstrating the validation of a recursive type representing a binary tree: 104 | 105 | ```ocaml 106 | type tree = 107 | | Leaf of (int[@greater_than 0]) 108 | | Node of { left : tree; [@dive] right : (tree[@dive]) } 109 | [@@deriving validate, show, eq] 110 | 111 | (* Example usage *) 112 | let my_tree = Node { left = Leaf 1; right = Leaf 2 } 113 | let validation_result = validate_tree my_tree 114 | ``` 115 | In this example: 116 | 117 | - `Leaf` is a variant that takes an integer, validated to be greater than 0. 118 | - `Node` is a variant representing a binary tree node with `left` and `right` branches, both of which are recursively validated as `tree` instances. 119 | 120 | #### Validating Circular Recursive Types 121 | `validate` also handles circular recursive types, which are useful for defining structures where two types refer to each other recursively. This feature is particularly useful for complex data models. Here's an example: 122 | 123 | ```ocaml 124 | type a = { 125 | a_id : int; [@greater_than 0] 126 | b : (b[@dive]) option 127 | } 128 | [@@deriving validate, show, eq] 129 | 130 | and b = { 131 | b_id : int; [@greater_than 0] 132 | a : (a[@dive]) option 133 | } 134 | [@@deriving validate, show, eq] 135 | 136 | (* Example usage *) 137 | let rec a_instance = { a_id = 1; b = Some { b_id = 2; a = Some a_instance } } 138 | let validation_result_a = validate_a a_instance 139 | 140 | let rec b_instance = { b_id = 1; a = Some { a_id = 2; b = Some b_instance } } 141 | let validation_result_b = validate_b b_instance 142 | ``` 143 | 144 | In this example: 145 | 146 | - Type `a` has an integer field `a_id` validated to be greater than 0, and an optional field `b` of type `b`. 147 | - Type `b` similarly has a `b_id` field and an optional field `a` of type `a`. 148 | - Both types use the `[@dive]` annotation to indicate recursive validation within their optional fields. 149 | 150 | ### Categorized Annotations 151 | 152 | String/List Annotations 153 | 154 | - `@min_length`: Validates minimum length of a string/list. 155 | - `@max_length`: Validates maximum length of a string/list. 156 | - `@length_equals`: Validates length of a string/list. 157 | 158 | String Annotations 159 | 160 | - `@url`: Checks if a string is a valid URL. 161 | - `@uuid`: Validates a string as a UUID. 162 | - `@numeric`: Ensures a string contains only numeric characters. 163 | - `@alpha`: Checks for alphabetic characters in a string. 164 | - `@alphanumeric`: Requires a string to be alphanumeric. 165 | - `@lowercase`: Validates a string to be in lowercase. 166 | - `@uppercase`: Ensures a string is in uppercase. 167 | - `@lowercase_alphanumeric`: Validates a lowercase alphanumeric string. 168 | - `@uppercase_alphanumeric`: Validates an uppercase alphanumeric string. 169 | - `@email`: Checks if a string is a valid email. 170 | - `@regex`: Checks if string matches given regex. Note: Under the hood it uses [ocaml-re](https://github.com/ocaml/ocaml-re) which does not support back-references and look-ahead/look-behind assertions. 171 | - `@ulid`: Ensures a string is a valid Universally Unique Lexicographically Sortable Identifier (ULID). 172 | - `@ipv4`: Validates that a string is a valid IPv4 address. 173 | - `@ipv6`: Ensures a string is a valid IPv6 address. 174 | - `@phone`: Validates that a string conforms to the E.164 international phone number format. 175 | - `@mac_address`: Ensures a string is a valid MAC address. 176 | 177 | 178 | Integer/Float Annotations 179 | 180 | - `@less_than`: Validates an integer/float to be less than a specified value. 181 | - `@less_than_or_equal`: Validates an integer/float to be less than or equal to a specified value. 182 | - `@greater_than`: Validates an integer/float to be greater than a specified value. 183 | - `@greater_than_or_equal`: Validates an integer/float to be greater than or equal to a specified value. 184 | - `@equal_to`: Validates an integer/float to be equal to a specified value. 185 | - `@not_equal_to`: Validates an integer/float to not be equal to a specified value. 186 | 187 | 188 | Annotations for Other Types 189 | 190 | - `@dive`: Used for nested record validation, allowing validation of each element within a composite structure like records or lists. 191 | 192 | Option Type Annotations 193 | 194 | - `@some`: Ensures that an option type is Some, indicating a value is present. 195 | - `@none`: Ensures that an option type is None, indicating no value is present. 196 | 197 | Advanced Annotations 198 | 199 | - `@custom`: This annotation allows you to define custom validation logic. You provide a function that takes one argument and returns a result, which is either `Ok ()` for successful validation or `Error validation_error` for a validation failure. 200 | 201 | ```ocaml 202 | let custom_validator str = 203 | if String.length str > 1 then Ok () 204 | else Error (Validate.BaseError { code = "custom_validator"; params = [] }) 205 | 206 | type custom_validator_record = { 207 | custom_validator : string; [@custom custom_validator] 208 | custom_inline_validator : int; 209 | [@custom 210 | fun i -> 211 | if i > 1 then Ok () 212 | else 213 | Error 214 | (Validate.BaseError { code = "custom_validator"; params = [] })] 215 | } 216 | [@@deriving validate] 217 | ``` 218 | 219 | - `@ignore_if`: This annotation accepts a function that takes the type itself as an argument and returns a boolean. If the function returns true, other validators for the field are ignored. 220 | 221 | ```ocaml 222 | type cond_record = { 223 | unit : string; 224 | temperature : int; [@greater_than_or_equal 0] [@ignore_if fun r -> r.unit <> "K"] 225 | } 226 | [@@deriving validate] 227 | ``` 228 | 229 | - `@some_if` and `@none_if`: These annotations are applicable only to option types. `@some_if` requires the option to be `Some` if the provided function returns true, and `@none_if` requires it to be `None` under the specified condition. 230 | 231 | ```ocaml 232 | type username_or_email = { 233 | username : string option; [@some_if fun r -> r.email = None] 234 | email : string option; [@none_if fun r -> Option.is_some r.username] 235 | } 236 | [@@deriving validate] 237 | ``` 238 | 239 | ## Error Handling 240 | 241 | In validate, the validation function returns a result type, which includes an Ok value equal to the input parameter, or an error parameter. 242 | The error types are defined as follows: 243 | 244 | - `base_validation_error`: Represents a basic validation error with a code and a list of parameters. 245 | 246 | ```ocaml 247 | type base_validation_error = { 248 | code : string; 249 | params : (string * string) list 250 | } 251 | ``` 252 | 253 | - `keyed_validation_errors`: Represents errors associated with specific keys e.g. for records key equal to field name and for tuples key is position in tuple. 254 | ```ocaml 255 | type keyed_validation_errors = string * validation_error list 256 | ``` 257 | 258 | - `index_validation_error`: Represents errors indexed by an integer, typically for list validations. 259 | ```ocaml 260 | type index_validation_error = int * validation_error list 261 | ``` 262 | - `validation_error`: The main error type which can be one of the following: 263 | - `BaseError`: Basic validation error. 264 | - `KeyedError`: Errors associated with specific keys. 265 | - `IterableError`: Errors in iterable structures like lists. 266 | - `GroupError`: A group of nested validation errors. 267 | ```ocaml 268 | type validation_error = 269 | | BaseError of base_validation_error 270 | | KeyedError of keyed_validation_errors list 271 | | IterableError of index_validation_error list 272 | | GroupError of validation_error list 273 | ``` 274 | 275 | ## Contributing 276 | 277 | Contributions to validate are warmly welcomed and appreciated. 278 | Whether it's opening issues for bug reports, suggesting new features, or submitting pull requests, 279 | all forms of contribution help in making validate better. 280 | -------------------------------------------------------------------------------- /ppx_derive_validate_test/record.ml: -------------------------------------------------------------------------------- 1 | module Test : sig 2 | type t = { min_module : string [@min_length 2] } 3 | [@@deriving validate, show, eq] 4 | end = struct 5 | type t = { min_module : string [@min_length 2] } 6 | [@@deriving validate, show, eq] 7 | end 8 | 9 | let _ = Test.show 10 | 11 | type other_test_record = { other_min : string [@min_length 2] } 12 | [@@deriving validate, show, eq] 13 | 14 | let custom_validator str = 15 | if String.length str > 1 then Ok () 16 | else Error (Validate.BaseError { code = "custom_validator"; params = [] }) 17 | 18 | type test_record = { 19 | min : (string[@min_length 2]); 20 | max : string; [@max_length 5] 21 | equals : string; [@length_equals 5] 22 | url : string; [@url] 23 | uuid : string; [@uuid] 24 | numeric : string; [@numeric] 25 | alpha : string; [@alpha] 26 | alphanumeric : string; [@alphanumeric] 27 | lowercase : string; [@lowercase] 28 | lowercase_alphanumeric : string; [@lowercase_alphanumeric] 29 | uppercase : string; [@uppercase] 30 | uppercase_alphanumeric : string; [@uppercase_alphanumeric] 31 | less_than : int; [@less_than 10] 32 | less_than_or_equal : int; [@less_than_or_equal 10] 33 | greater_than : int; [@greater_than 5] 34 | greater_than_or_equal : int; [@greater_than_or_equal 5] 35 | equal_to : int; [@equal_to 5] 36 | not_equal_to : int; [@not_equal_to 10] 37 | option_some : (string[@min_length 2]) option; 38 | option_none : (string[@min_length 2]) option; 39 | test_list : (string[@min_length 2]) list; 40 | list_min_length : (string[@min_length 1]) list; [@min_length 3] 41 | list_max_length : (string[@max_length 3]) list; [@max_length 5] 42 | other_test_record : other_test_record; [@dive] 43 | module_test_record : Test.t; [@dive] 44 | other_test_record_list : (other_test_record[@dive]) list; [@min_length 2] 45 | email : string; [@email] 46 | regex : string; [@regex "^test[a-z]+$"] 47 | nested_list : ((string[@max_length 1]) list[@max_length 1]) list; 48 | [@max_length 1] 49 | ulid : string; [@ulid] 50 | ipv4 : string; [@ipv4] 51 | ipv6 : string; [@ipv6] 52 | phone : string; [@phone] 53 | mac_address : string; [@mac_address] 54 | custom_validator : string; [@custom custom_validator] 55 | custom_inline_validator : int; 56 | [@custom 57 | fun i -> 58 | if i > 1 then Ok () 59 | else 60 | Error 61 | (Validate.BaseError { code = "custom_validator"; params = [] })] 62 | some : string option; [@some] 63 | none : string option; [@none] 64 | } 65 | [@@deriving validate, show, eq] 66 | 67 | let test_record_testable = Alcotest.testable pp_test_record equal_test_record 68 | 69 | let test_err () = 70 | let result = 71 | validate_test_record 72 | { 73 | min = "1"; 74 | max = "123456"; 75 | equals = "123456"; 76 | url = "invalid url"; 77 | uuid = "invalid uuid"; 78 | numeric = "123a"; 79 | alpha = "123"; 80 | alphanumeric = "122@"; 81 | lowercase = "aBC"; 82 | lowercase_alphanumeric = "aBC@"; 83 | uppercase = "Abc"; 84 | uppercase_alphanumeric = "Abc@"; 85 | less_than = 10; 86 | less_than_or_equal = 11; 87 | greater_than = 5; 88 | greater_than_or_equal = 4; 89 | equal_to = 4; 90 | not_equal_to = 10; 91 | option_some = Some "1"; 92 | option_none = None; 93 | test_list = [ "1"; "234"; "5" ]; 94 | list_min_length = [ ""; "2" ]; 95 | list_max_length = [ "1"; "2"; "3"; "4"; "5"; "67890" ]; 96 | other_test_record = { other_min = "1" }; 97 | module_test_record = { Test.min_module = "1" }; 98 | other_test_record_list = [ { other_min = "1" } ]; 99 | email = "invalid email"; 100 | regex = "invalid regex"; 101 | nested_list = 102 | [ [ "111"; "2" ]; [ "12" ]; [ "1" ]; [ "111"; "fffff"; "123" ] ]; 103 | ulid = "invalid ulid"; 104 | ipv4 = "invalid ipv4"; 105 | ipv6 = "invalid ipv6"; 106 | phone = "invalid phone"; 107 | mac_address = "invalid mac address"; 108 | custom_validator = "1"; 109 | custom_inline_validator = 1; 110 | some = None; 111 | none = Some "1"; 112 | } 113 | in 114 | Alcotest.(check (result test_record_testable Error.validation_error_testable)) 115 | "returns Error" 116 | (Error 117 | (Validate.KeyedError 118 | [ 119 | ( "none", 120 | [ Validate.BaseError { code = "expect_none"; params = [] } ] ); 121 | ( "some", 122 | [ Validate.BaseError { code = "expect_some"; params = [] } ] ); 123 | ( "custom_inline_validator", 124 | [ Validate.BaseError { code = "custom_validator"; params = [] } ] 125 | ); 126 | ( "custom_validator", 127 | [ Validate.BaseError { code = "custom_validator"; params = [] } ] 128 | ); 129 | ( "mac_address", 130 | [ 131 | Validate.BaseError { code = "invalid_mac_address"; params = [] }; 132 | ] ); 133 | ( "phone", 134 | [ 135 | Validate.BaseError 136 | { code = "invalid_phone_number"; params = [] }; 137 | ] ); 138 | ( "ipv6", 139 | [ Validate.BaseError { code = "invalid_ipv6"; params = [] } ] ); 140 | ( "ipv4", 141 | [ Validate.BaseError { code = "invalid_ipv4"; params = [] } ] ); 142 | ( "ulid", 143 | [ Validate.BaseError { code = "invalid_ulid"; params = [] } ] ); 144 | ( "nested_list", 145 | [ 146 | Validate.BaseError 147 | { code = "max_length"; params = [ ("threshold", "1") ] }; 148 | Validate.IterableError 149 | [ 150 | ( 3, 151 | [ 152 | Validate.BaseError 153 | { 154 | code = "max_length"; 155 | params = [ ("threshold", "1") ]; 156 | }; 157 | Validate.IterableError 158 | [ 159 | ( 2, 160 | [ 161 | Validate.BaseError 162 | { 163 | code = "max_length"; 164 | params = [ ("threshold", "1") ]; 165 | }; 166 | ] ); 167 | ( 1, 168 | [ 169 | Validate.BaseError 170 | { 171 | code = "max_length"; 172 | params = [ ("threshold", "1") ]; 173 | }; 174 | ] ); 175 | ( 0, 176 | [ 177 | Validate.BaseError 178 | { 179 | code = "max_length"; 180 | params = [ ("threshold", "1") ]; 181 | }; 182 | ] ); 183 | ]; 184 | ] ); 185 | ( 1, 186 | [ 187 | Validate.IterableError 188 | [ 189 | ( 0, 190 | [ 191 | Validate.BaseError 192 | { 193 | code = "max_length"; 194 | params = [ ("threshold", "1") ]; 195 | }; 196 | ] ); 197 | ]; 198 | ] ); 199 | ( 0, 200 | [ 201 | Validate.BaseError 202 | { 203 | code = "max_length"; 204 | params = [ ("threshold", "1") ]; 205 | }; 206 | Validate.IterableError 207 | [ 208 | ( 0, 209 | [ 210 | Validate.BaseError 211 | { 212 | code = "max_length"; 213 | params = [ ("threshold", "1") ]; 214 | }; 215 | ] ); 216 | ]; 217 | ] ); 218 | ]; 219 | ] ); 220 | ( "regex", 221 | [ Validate.BaseError { code = "invalid_pattern"; params = [] } ] 222 | ); 223 | ( "email", 224 | [ Validate.BaseError { code = "invalid_email"; params = [] } ] ); 225 | ( "other_test_record_list", 226 | [ 227 | Validate.BaseError 228 | { code = "min_length"; params = [ ("threshold", "2") ] }; 229 | Validate.IterableError 230 | [ 231 | ( 0, 232 | [ 233 | Validate.KeyedError 234 | [ 235 | ( "other_min", 236 | [ 237 | Validate.BaseError 238 | { 239 | code = "min_length"; 240 | params = [ ("threshold", "2") ]; 241 | }; 242 | ] ); 243 | ]; 244 | ] ); 245 | ]; 246 | ] ); 247 | ( "module_test_record", 248 | [ 249 | Validate.KeyedError 250 | [ 251 | ( "min_module", 252 | [ 253 | Validate.BaseError 254 | { 255 | code = "min_length"; 256 | params = [ ("threshold", "2") ]; 257 | }; 258 | ] ); 259 | ]; 260 | ] ); 261 | ( "other_test_record", 262 | [ 263 | Validate.KeyedError 264 | [ 265 | ( "other_min", 266 | [ 267 | Validate.BaseError 268 | { 269 | code = "min_length"; 270 | params = [ ("threshold", "2") ]; 271 | }; 272 | ] ); 273 | ]; 274 | ] ); 275 | ( "list_max_length", 276 | [ 277 | Validate.BaseError 278 | { code = "max_length"; params = [ ("threshold", "5") ] }; 279 | Validate.IterableError 280 | [ 281 | ( 5, 282 | [ 283 | Validate.BaseError 284 | { 285 | Validate.code = "max_length"; 286 | params = [ ("threshold", "3") ]; 287 | }; 288 | ] ); 289 | ]; 290 | ] ); 291 | ( "list_min_length", 292 | [ 293 | Validate.BaseError 294 | { code = "min_length"; params = [ ("threshold", "3") ] }; 295 | Validate.IterableError 296 | [ 297 | ( 0, 298 | [ 299 | Validate.BaseError 300 | { 301 | code = "min_length"; 302 | params = [ ("threshold", "1") ]; 303 | }; 304 | ] ); 305 | ]; 306 | ] ); 307 | ( "test_list", 308 | [ 309 | Validate.IterableError 310 | [ 311 | ( 2, 312 | [ 313 | Validate.BaseError 314 | { 315 | code = "min_length"; 316 | params = [ ("threshold", "2") ]; 317 | }; 318 | ] ); 319 | ( 0, 320 | [ 321 | Validate.BaseError 322 | { 323 | code = "min_length"; 324 | params = [ ("threshold", "2") ]; 325 | }; 326 | ] ); 327 | ]; 328 | ] ); 329 | ( "option_some", 330 | [ 331 | Validate.GroupError 332 | [ 333 | Validate.BaseError 334 | { code = "min_length"; params = [ ("threshold", "2") ] }; 335 | ]; 336 | ] ); 337 | ( "not_equal_to", 338 | [ 339 | Validate.BaseError 340 | { code = "value_not_equal_to"; params = [ ("value", "10") ] }; 341 | ] ); 342 | ( "equal_to", 343 | [ 344 | Validate.BaseError 345 | { code = "value_equal_to"; params = [ ("value", "5") ] }; 346 | ] ); 347 | ( "greater_than_or_equal", 348 | [ 349 | Validate.BaseError 350 | { 351 | code = "value_greater_than_or_equal"; 352 | params = [ ("threshold", "5") ]; 353 | }; 354 | ] ); 355 | ( "greater_than", 356 | [ 357 | Validate.BaseError 358 | { 359 | code = "value_greater_than"; 360 | params = [ ("threshold", "5") ]; 361 | }; 362 | ] ); 363 | ( "less_than_or_equal", 364 | [ 365 | Validate.BaseError 366 | { 367 | code = "value_less_than_or_equal"; 368 | params = [ ("threshold", "10") ]; 369 | }; 370 | ] ); 371 | ( "less_than", 372 | [ 373 | Validate.BaseError 374 | { code = "value_less_than"; params = [ ("threshold", "10") ] }; 375 | ] ); 376 | ( "uppercase_alphanumeric", 377 | [ 378 | Validate.BaseError 379 | { code = "invalid_uppercase_alphanumeric"; params = [] }; 380 | ] ); 381 | ( "uppercase", 382 | [ Validate.BaseError { code = "invalid_uppercase"; params = [] } ] 383 | ); 384 | ( "lowercase_alphanumeric", 385 | [ 386 | Validate.BaseError 387 | { code = "invalid_lowercase_alphanumeric"; params = [] }; 388 | ] ); 389 | ( "lowercase", 390 | [ Validate.BaseError { code = "invalid_lowercase"; params = [] } ] 391 | ); 392 | ( "alphanumeric", 393 | [ 394 | Validate.BaseError 395 | { code = "invalid_alphanumeric"; params = [] }; 396 | ] ); 397 | ( "alpha", 398 | [ Validate.BaseError { code = "invalid_alpha"; params = [] } ] ); 399 | ( "numeric", 400 | [ Validate.BaseError { code = "invalid_numeric"; params = [] } ] 401 | ); 402 | ( "uuid", 403 | [ Validate.BaseError { code = "invalid_uuid"; params = [] } ] ); 404 | ("url", [ Validate.BaseError { code = "invalid_url"; params = [] } ]); 405 | ( "equals", 406 | [ 407 | Validate.BaseError 408 | { code = "length_equals"; params = [ ("value", "5") ] }; 409 | ] ); 410 | ( "max", 411 | [ 412 | Validate.BaseError 413 | { code = "max_length"; params = [ ("threshold", "5") ] }; 414 | ] ); 415 | ( "min", 416 | [ 417 | Validate.BaseError 418 | { code = "min_length"; params = [ ("threshold", "2") ] }; 419 | ] ); 420 | ])) 421 | result 422 | 423 | let test_ok () = 424 | let r = 425 | { 426 | min = "12"; 427 | max = "12345"; 428 | equals = "12345"; 429 | url = "https://www.google.com"; 430 | uuid = "123e4567-e89b-12d3-a456-426614174000"; 431 | numeric = "123"; 432 | alpha = "abc"; 433 | alphanumeric = "123abc"; 434 | lowercase = "abc"; 435 | lowercase_alphanumeric = "abc123"; 436 | uppercase = "ABC"; 437 | uppercase_alphanumeric = "ABC123"; 438 | less_than = 9; 439 | less_than_or_equal = 10; 440 | greater_than = 6; 441 | greater_than_or_equal = 5; 442 | equal_to = 5; 443 | not_equal_to = 9; 444 | option_some = Some "12"; 445 | option_none = None; 446 | test_list = [ "123"; "456"; "789" ]; 447 | list_min_length = [ "1"; "2"; "3" ]; 448 | list_max_length = [ "1"; "2"; "3"; "4"; "5" ]; 449 | other_test_record = { other_min = "12" }; 450 | module_test_record = { Test.min_module = "12" }; 451 | other_test_record_list = [ { other_min = "12" }; { other_min = "12" } ]; 452 | email = "example@gmail.com"; 453 | regex = "testa"; 454 | nested_list = [ [ "1" ] ]; 455 | ulid = "01E2WQZJXZJZJZJZJZJZJZJZJZ"; 456 | ipv4 = "192.168.0.255"; 457 | ipv6 = "2001:0db8:85a3:0000:0000:8a2e:0370:7334"; 458 | phone = "+12025550176"; 459 | mac_address = "01:23:45:67:89:ab"; 460 | custom_validator = "12"; 461 | custom_inline_validator = 2; 462 | some = Some "12"; 463 | none = None; 464 | } 465 | in 466 | let result = validate_test_record r in 467 | Alcotest.(check (result test_record_testable Error.validation_error_testable)) 468 | "returns Ok" (Ok r) result 469 | 470 | let t = 471 | let open Alcotest in 472 | ( "record", 473 | [ test_case "Error" `Quick test_err; test_case "Ok" `Quick test_ok ] ) 474 | -------------------------------------------------------------------------------- /ppx_derive_validate/validators.ml: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Exps 3 | open Simple_type 4 | 5 | type number = Int of int | Float of float [@@deriving show] 6 | type func = Var of expression | Func of expression 7 | 8 | let extract_func = function Var var -> var | Func func -> func 9 | 10 | let extract_func_option = function 11 | | Some r -> Some (extract_func r) 12 | | None -> None 13 | 14 | let process_numeric_attribute = function 15 | | Pconst_integer (i, _) -> Int (int_of_string i) 16 | | Pconst_float (f, _) -> Float (float_of_string f) 17 | | _ -> Location.raise_errorf "Attribute must be an integer or float" 18 | 19 | let number_attribute name context = 20 | Attribute.declare 21 | Printf.(sprintf "ppx_derive_validate.%s" name) 22 | context 23 | Ast_pattern.(single_expr_payload (pexp_constant __)) 24 | process_numeric_attribute 25 | 26 | let int_attrribute name context = 27 | Attribute.declare 28 | Printf.(sprintf "ppx_derive_validate.%s" name) 29 | context 30 | Ast_pattern.(single_expr_payload (eint __)) 31 | (fun x -> x) 32 | 33 | let string_attrribute name context = 34 | Attribute.declare 35 | Printf.(sprintf "ppx_derive_validate.%s" name) 36 | context 37 | Ast_pattern.(single_expr_payload (estring __)) 38 | (fun x -> x) 39 | 40 | let unit_attribute name context = 41 | Attribute.declare 42 | Printf.(sprintf "ppx_derive_validate.%s" name) 43 | context 44 | Ast_pattern.(pstr nil) 45 | () 46 | 47 | let function_attribute name context = 48 | Attribute.declare name context 49 | Ast_pattern.(pstr (pstr_eval __ nil ^:: nil)) 50 | (fun x -> 51 | match x with 52 | | { pexp_desc = Pexp_ident _; _ } -> Var x 53 | | { pexp_desc = Pexp_fun (Nolabel, None, _, _); _ } -> Func x 54 | | _ -> failwith "Unsupported expression type for attribute") 55 | 56 | type 'a validator_params = { 57 | name : string; 58 | build_exp : 'a -> loc_type -> expression option; 59 | } 60 | 61 | let get_exp attr (build_exp : 'a -> expression) v loc_type = 62 | Attribute.get attr v |> Option.map (fun x -> build_exp (x, loc_type)) 63 | 64 | let length_exp f = 65 | match f.typ with 66 | | String -> module_ident_exp ~loc:f.loc "String" "length" 67 | | List _ -> module_ident_exp ~loc:f.loc "List" "length" 68 | | _ -> 69 | Location.raise_errorf ~loc:f.loc "length is not supported for this type" 70 | 71 | let validate_number_func_exp ~loc name value = 72 | match value with 73 | | Int i -> 74 | validate_func_exp name ~loc 75 | [ 76 | (Nolabel, simple_ident_exp ~loc "string_of_int"); (Nolabel, int_exp i); 77 | ] 78 | | Float f -> 79 | validate_func_exp name ~loc 80 | [ 81 | (Nolabel, simple_ident_exp ~loc "string_of_float"); 82 | (Nolabel, float_exp f); 83 | ] 84 | 85 | let validators ctx = 86 | [ 87 | { 88 | name = "min_length"; 89 | build_exp = 90 | get_exp (int_attrribute "min_length" ctx) (fun (x, loc_type) -> 91 | validate_func_exp "validate_min_length" ~loc:loc_type.loc 92 | [ (Nolabel, length_exp loc_type); (Nolabel, int_exp x) ]); 93 | }; 94 | { 95 | name = "max_length"; 96 | build_exp = 97 | get_exp (int_attrribute "max_length" ctx) (fun (x, loc_type) -> 98 | validate_func_exp "validate_max_length" ~loc:loc_type.loc 99 | [ (Nolabel, length_exp loc_type); (Nolabel, int_exp x) ]); 100 | }; 101 | { 102 | name = "length_equals"; 103 | build_exp = 104 | get_exp (int_attrribute "length_equals" ctx) (fun (x, loc_type) -> 105 | validate_func_exp "validate_length_equals" ~loc:loc_type.loc 106 | [ (Nolabel, length_exp loc_type); (Nolabel, int_exp x) ]); 107 | }; 108 | { 109 | name = "url"; 110 | build_exp = 111 | get_exp (unit_attribute "url" ctx) (fun (_, loc_type) -> 112 | validate_func_exp "validate_url" ~loc:loc_type.loc []); 113 | }; 114 | { 115 | name = "uuid"; 116 | build_exp = 117 | get_exp (unit_attribute "uuid" ctx) (fun (_, loc_type) -> 118 | validate_func_exp "validate_uuid" ~loc:loc_type.loc []); 119 | }; 120 | { 121 | name = "ulid"; 122 | build_exp = 123 | get_exp (unit_attribute "ulid" ctx) (fun (_, loc_type) -> 124 | validate_func_exp "validate_ulid" ~loc:loc_type.loc []); 125 | }; 126 | { 127 | name = "email"; 128 | build_exp = 129 | get_exp (unit_attribute "email" ctx) (fun (_, loc_type) -> 130 | validate_func_exp "validate_email" ~loc:loc_type.loc []); 131 | }; 132 | { 133 | name = "numeric"; 134 | build_exp = 135 | get_exp (unit_attribute "numeric" ctx) (fun (_, loc_type) -> 136 | validate_func_exp "validate_numeric" ~loc:loc_type.loc []); 137 | }; 138 | { 139 | name = "alpha"; 140 | build_exp = 141 | get_exp (unit_attribute "alpha" ctx) (fun (_, loc_type) -> 142 | validate_func_exp "validate_alpha" ~loc:loc_type.loc []); 143 | }; 144 | { 145 | name = "alphanumeric"; 146 | build_exp = 147 | get_exp (unit_attribute "alphanumeric" ctx) (fun (_, loc_type) -> 148 | validate_func_exp "validate_alphanumeric" ~loc:loc_type.loc []); 149 | }; 150 | { 151 | name = "lowercase"; 152 | build_exp = 153 | get_exp (unit_attribute "lowercase" ctx) (fun (_, loc_type) -> 154 | validate_func_exp "validate_lowercase" ~loc:loc_type.loc []); 155 | }; 156 | { 157 | name = "lowercase_alphanumeric"; 158 | build_exp = 159 | get_exp (unit_attribute "lowercase_alphanumeric" ctx) 160 | (fun (_, loc_type) -> 161 | validate_func_exp "validate_lowercase_alphanumeric" 162 | ~loc:loc_type.loc []); 163 | }; 164 | { 165 | name = "uppercase"; 166 | build_exp = 167 | get_exp (unit_attribute "uppercase" ctx) (fun (_, loc_type) -> 168 | validate_func_exp "validate_uppercase" ~loc:loc_type.loc []); 169 | }; 170 | { 171 | name = "uppercase_alphanumeric"; 172 | build_exp = 173 | get_exp (unit_attribute "uppercase_alphanumeric" ctx) 174 | (fun (_, loc_type) -> 175 | validate_func_exp "validate_uppercase_alphanumeric" 176 | ~loc:loc_type.loc []); 177 | }; 178 | { 179 | name = "less_than"; 180 | build_exp = 181 | get_exp (number_attribute "less_than" ctx) (fun (x, loc_type) -> 182 | validate_number_func_exp ~loc:loc_type.loc "validate_less_than" x); 183 | }; 184 | { 185 | name = "less_than_or_equal"; 186 | build_exp = 187 | get_exp (number_attribute "less_than_or_equal" ctx) 188 | (fun (x, loc_type) -> 189 | validate_number_func_exp ~loc:loc_type.loc 190 | "validate_less_than_or_equal" x); 191 | }; 192 | { 193 | name = "greater_than"; 194 | build_exp = 195 | get_exp (number_attribute "greater_than" ctx) (fun (x, loc_type) -> 196 | validate_number_func_exp ~loc:loc_type.loc "validate_greater_than" x); 197 | }; 198 | { 199 | name = "greater_than_or_equal"; 200 | build_exp = 201 | get_exp (number_attribute "greater_than_or_equal" ctx) 202 | (fun (x, loc_type) -> 203 | validate_number_func_exp ~loc:loc_type.loc 204 | "validate_greater_than_or_equal" x); 205 | }; 206 | { 207 | name = "equal_to"; 208 | build_exp = 209 | get_exp (number_attribute "equal_to" ctx) (fun (x, loc_type) -> 210 | validate_number_func_exp ~loc:loc_type.loc "validate_equal_to" x); 211 | }; 212 | { 213 | name = "not_equal_to"; 214 | build_exp = 215 | get_exp (number_attribute "not_equal_to" ctx) (fun (x, loc_type) -> 216 | validate_number_func_exp ~loc:loc_type.loc "validate_not_equal_to" x); 217 | }; 218 | { 219 | name = "regex"; 220 | build_exp = 221 | get_exp (string_attrribute "regex" ctx) (fun (x, loc_type) -> 222 | validate_func_exp "validate_str_regex" ~loc:loc_type.loc 223 | [ (Nolabel, string_exp ~loc:loc_type.loc x) ]); 224 | }; 225 | { 226 | name = "ipv4"; 227 | build_exp = 228 | get_exp (unit_attribute "ipv4" ctx) (fun (_, loc_type) -> 229 | validate_func_exp "validate_ipv4" ~loc:loc_type.loc []); 230 | }; 231 | { 232 | name = "ipv6"; 233 | build_exp = 234 | get_exp (unit_attribute "ipv6" ctx) (fun (_, loc_type) -> 235 | validate_func_exp "validate_ipv6" ~loc:loc_type.loc []); 236 | }; 237 | { 238 | name = "phone"; 239 | build_exp = 240 | get_exp (unit_attribute "phone" ctx) (fun (_, loc_type) -> 241 | validate_func_exp "validate_phone_number" ~loc:loc_type.loc []); 242 | }; 243 | { 244 | name = "mac_address"; 245 | build_exp = 246 | get_exp (unit_attribute "mac_address" ctx) (fun (_, loc_type) -> 247 | validate_func_exp "validate_mac_address" ~loc:loc_type.loc []); 248 | }; 249 | { 250 | name = "custom"; 251 | build_exp = 252 | get_exp (function_attribute "custom" ctx) (fun (exp, _) -> 253 | match exp with Var var -> var | Func func -> func); 254 | }; 255 | { 256 | name = "some"; 257 | build_exp = 258 | get_exp (unit_attribute "some" ctx) (fun (_, loc_type) -> 259 | validate_func_exp "validate_some" ~loc:loc_type.loc []); 260 | }; 261 | { 262 | name = "none"; 263 | build_exp = 264 | get_exp (unit_attribute "none" ctx) (fun (_, loc_type) -> 265 | validate_func_exp "validate_none" ~loc:loc_type.loc []); 266 | }; 267 | { 268 | name = "some_if"; 269 | build_exp = 270 | get_exp (function_attribute "some_if" ctx) (fun (func, loc_type) -> 271 | let exp = func |> extract_func in 272 | let condition = 273 | apply_exp exp 274 | [ (Nolabel, simple_ident_exp ~loc:loc_type.loc "x") ] 275 | in 276 | validate_func_exp "validate_some_if" ~loc:loc_type.loc 277 | [ (Nolabel, condition) ]); 278 | }; 279 | { 280 | name = "none_if"; 281 | build_exp = 282 | get_exp (function_attribute "none_if" ctx) (fun (func, loc_type) -> 283 | let exp = func |> extract_func in 284 | let condition = 285 | apply_exp exp 286 | [ (Nolabel, simple_ident_exp ~loc:loc_type.loc "x") ] 287 | in 288 | validate_func_exp "validate_none_if" ~loc:loc_type.loc 289 | [ (Nolabel, condition) ]); 290 | }; 291 | ] 292 | 293 | let ct_validators = validators Attribute.Context.core_type 294 | let ld_validators = validators Attribute.Context.label_declaration 295 | let ct_dive_attribute = unit_attribute "dive" Attribute.Context.core_type 296 | 297 | let ct_ignore_if_attribute = 298 | function_attribute "ignore_if" Attribute.Context.core_type 299 | 300 | let ct_divable ct = Attribute.get ct_dive_attribute ct |> Option.is_some 301 | 302 | let rec cts_has_recursive cts searched_type = 303 | let loc_types = List.map extract_loc_type cts in 304 | let cts_to_loc_types = List.combine cts loc_types in 305 | let recursive (ct, loc_type) = 306 | match loc_type.typ with 307 | | List (_, ct) -> cts_has_recursive [ ct ] searched_type 308 | | Option (_, ct) -> cts_has_recursive [ ct ] searched_type 309 | | Tuple t -> 310 | t |> List.map (fun (_, ct) -> ct) |> fun cts -> 311 | cts_has_recursive cts searched_type 312 | | Other type_name -> ( 313 | match type_name with 314 | | Lident name -> 315 | let same_type = name = searched_type in 316 | let divable = ct_divable ct in 317 | same_type && divable 318 | | _ -> false) 319 | | _ -> false 320 | in 321 | 322 | cts_to_loc_types |> List.exists recursive 323 | 324 | let ld_dive_attribute = 325 | unit_attribute "dive" Attribute.Context.label_declaration 326 | 327 | let ld_ignore_if_attribute = 328 | function_attribute "ignore_if" Attribute.Context.label_declaration 329 | 330 | let available_ignore_if_value ld ct = 331 | let ld_ignore_if_exp = Attribute.get ld_ignore_if_attribute ld in 332 | let ct_ignore_if_exp = Attribute.get ct_ignore_if_attribute ct in 333 | match (ld_ignore_if_exp, ct_ignore_if_exp) with 334 | | Some ld_ignore_if_exp, _ -> Some ld_ignore_if_exp 335 | | _, Some ct_ignore_if_exp -> Some ct_ignore_if_exp 336 | | _ -> None 337 | 338 | let ld_divable ld = Attribute.get ld_dive_attribute ld |> Option.is_some 339 | 340 | let ct_validators_to_apply ct loc_type = 341 | ct_validators |> List.filter_map (fun v -> v.build_exp ct loc_type) 342 | 343 | let ld_validators_to_apply ld loc_type = 344 | ld_validators |> List.filter_map (fun v -> v.build_exp ld loc_type) 345 | 346 | let lds_has_recursive lds searched_type = 347 | let loc_types = List.map extract_record_field lds in 348 | let lds_to_loc_types = List.combine lds loc_types in 349 | let recursive (ld, record_field) = 350 | match record_field.loc_type.typ with 351 | | List (_, ct) -> cts_has_recursive [ ct ] searched_type 352 | | Option (_, ct) -> cts_has_recursive [ ct ] searched_type 353 | | Tuple t -> 354 | t |> List.map (fun (_, ct) -> ct) |> fun cts -> 355 | cts_has_recursive cts searched_type 356 | | Other type_name -> ( 357 | match type_name with 358 | | Lident name -> 359 | let same_type = name = searched_type in 360 | let ld_divable = ld_divable ld in 361 | let ct_divable = ct_divable ld.pld_type in 362 | let divable = ld_divable || ct_divable in 363 | same_type && divable 364 | | _ -> false) 365 | | _ -> false 366 | in 367 | 368 | lds_to_loc_types |> List.exists recursive 369 | 370 | let rec validators_list_exp ~validators ~divable ~ignore_if_exp loc_type = 371 | match loc_type.typ with 372 | | List (t, inner_type) -> 373 | let inner_divable = ct_divable inner_type in 374 | let inner_loc_type = { loc_type with typ = t } in 375 | let inner_validators = ct_validators_to_apply inner_type inner_loc_type in 376 | let inner_ignore_if_exp = 377 | Attribute.get ct_ignore_if_attribute inner_type |> extract_func_option 378 | in 379 | let deep_validators_exp = 380 | inner_loc_type 381 | |> validators_list_exp ~validators:inner_validators 382 | ~divable:inner_divable ~ignore_if_exp:inner_ignore_if_exp 383 | |> validate_list_exp ~loc:loc_type.loc 384 | in 385 | let all_validators = deep_validators_exp :: validators in 386 | 387 | all_validators |> list_exp ~loc:loc_type.loc 388 | |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 389 | | Other type_name -> 390 | let list_exp = 391 | match divable with 392 | | true -> 393 | list_exp ~loc:loc_type.loc 394 | [ 395 | ignore_ok_exp ~loc:loc_type.loc 396 | @@ dive_exp ~loc:loc_type.loc type_name; 397 | ] 398 | |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 399 | | false -> list_exp ~loc:loc_type.loc [] 400 | in 401 | list_exp |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 402 | | Tuple types -> 403 | let args_count = List.length types in 404 | let tuple_extractor_exp = tuple_element_extractor_fun_exp args_count in 405 | let indexes = List.init args_count (fun i -> i) in 406 | let indexed_types = List.combine indexes types in 407 | let mapper (i, (t, ct)) = 408 | let inner_type = { loc_type with typ = t } in 409 | let inner_validators = ct_validators_to_apply ct inner_type in 410 | let inner_divable = ct_divable ct in 411 | let inner_ignore_if_exp = 412 | Attribute.get ct_ignore_if_attribute ct |> extract_func_option 413 | in 414 | inner_type 415 | |> validators_list_exp ~validators:inner_validators 416 | ~divable:inner_divable ~ignore_if_exp:inner_ignore_if_exp 417 | |> validate_field_exp ~loc:ct.ptyp_loc (string_of_int i) 418 | (tuple_extractor_exp ~loc:ct.ptyp_loc i) 419 | in 420 | let body = 421 | indexed_types |> List.map mapper |> list_exp ~loc:loc_type.loc 422 | |> validate_keyed_exp ~loc:loc_type.loc 423 | in 424 | 425 | [ body ] |> list_exp ~loc:loc_type.loc 426 | |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 427 | | Option (t, inner_ct) -> 428 | let inner_type = { loc_type with typ = t } in 429 | 430 | let inner_validators = ct_validators_to_apply inner_ct inner_type in 431 | let inner_divable = ct_divable inner_ct in 432 | let inner_ignore_if_exp = 433 | Attribute.get ct_ignore_if_attribute inner_ct |> extract_func_option 434 | in 435 | let inner_validators = 436 | inner_type 437 | |> validators_list_exp ~divable:inner_divable 438 | ~validators:inner_validators ~ignore_if_exp:inner_ignore_if_exp 439 | |> validate_option ~loc:loc_type.loc 440 | in 441 | 442 | inner_validators :: validators 443 | |> list_exp ~loc:loc_type.loc 444 | |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 445 | | _ -> 446 | validators |> list_exp ~loc:loc_type.loc 447 | |> ignore_if_func_exp ~loc:loc_type.loc ignore_if_exp 448 | 449 | let type_validator_exp (ct : core_type) = 450 | let loc_type = extract_loc_type ct in 451 | let validators = ct_validators_to_apply ct loc_type in 452 | let divable = ct_divable ct in 453 | let ignore_if_exp = 454 | Attribute.get ct_ignore_if_attribute ct |> extract_func_option 455 | in 456 | validators_list_exp ~validators ~divable ~ignore_if_exp loc_type 457 | |> validate_group_exp ~loc:ct.ptyp_loc 458 | 459 | let field_validator_exp (ld : label_declaration) = 460 | let f = extract_record_field ld in 461 | let divable_ld = ld_divable ld in 462 | let divable_ct = ct_divable ld.pld_type in 463 | let divable = divable_ld || divable_ct in 464 | let ld_validators = ld_validators_to_apply ld f.loc_type in 465 | let ct_validators = ct_validators_to_apply ld.pld_type f.loc_type in 466 | 467 | let ignore_if_exp = 468 | available_ignore_if_value ld ld.pld_type |> extract_func_option 469 | in 470 | let validators = ld_validators @ ct_validators in 471 | f.loc_type 472 | |> validators_list_exp ~validators ~divable ~ignore_if_exp 473 | |> validate_field_exp ~loc:ld.pld_loc f.name 474 | (field_extractor_exp ~loc:f.loc_type.loc f.name) 475 | 476 | let validate_record_exp ~loc label_declarations = 477 | let exp = 478 | label_declarations 479 | |> List.map field_validator_exp 480 | |> list_exp ~loc |> validate_keyed_exp ~loc |> validate_exp ~loc 481 | in 482 | exp 483 | 484 | let validate_abstract_exp ~loc ct = 485 | ct |> type_validator_exp |> validate_exp ~loc 486 | 487 | let validate_variant_tuple_exp ~variant_name cts = 488 | let args_count = List.length cts in 489 | let tuple_extractor_exp = 490 | variant_tuple_extractor_exp variant_name args_count 491 | in 492 | let indexes = List.init args_count (fun i -> i) in 493 | let indexed_types = List.combine indexes cts in 494 | let mapper (i, ct) = 495 | let inner_type = extract_loc_type ct in 496 | let inner_divable = ct_divable ct in 497 | 498 | let inner_validators = ct_validators_to_apply ct inner_type in 499 | let inner_ignore_if_exp = 500 | Attribute.get ct_ignore_if_attribute ct |> extract_func_option 501 | in 502 | 503 | match (List.length inner_validators, inner_divable) with 504 | | 0, false -> None 505 | | _ -> 506 | let name = Printf.sprintf "%s.%s" variant_name (string_of_int i) in 507 | inner_type 508 | |> validators_list_exp ~validators:inner_validators 509 | ~divable:inner_divable ~ignore_if_exp:inner_ignore_if_exp 510 | |> validate_named_value_exp ~loc:ct.ptyp_loc name 511 | (tuple_extractor_exp ~loc:ct.ptyp_loc i) 512 | |> Option.some 513 | in 514 | indexed_types |> List.filter_map mapper 515 | 516 | let validate_variant_record_exp ~variant_name lds = 517 | let field_names = List.map (fun ld -> ld.pld_name.txt) lds in 518 | let variant_extractor_exp = 519 | variant_record_extractor_exp variant_name field_names 520 | in 521 | let mapper ld = 522 | let inner_type = extract_record_field ld in 523 | let field_name = ld.pld_name.txt in 524 | let name = Printf.sprintf "%s.%s" variant_name ld.pld_name.txt in 525 | let divable_ld = ld_divable ld in 526 | let divable_ct = ct_divable ld.pld_type in 527 | let divable = divable_ld || divable_ct in 528 | let ld_validators = ld_validators_to_apply ld inner_type.loc_type in 529 | let ct_validators = 530 | ct_validators_to_apply ld.pld_type inner_type.loc_type 531 | in 532 | let ignore_if_exp = 533 | available_ignore_if_value ld ld.pld_type |> extract_func_option 534 | in 535 | let validators = ld_validators @ ct_validators in 536 | match (List.length validators, divable) with 537 | | 0, false -> None 538 | | _ -> 539 | inner_type.loc_type 540 | |> validators_list_exp ~validators ~divable ~ignore_if_exp 541 | |> validate_named_value_exp ~loc:ld.pld_loc name 542 | (variant_extractor_exp ~loc:ld.pld_loc field_name) 543 | |> Option.some 544 | in 545 | lds |> List.filter_map mapper 546 | 547 | let validate_constructor_declaration_exp cd = 548 | match cd.pcd_args with 549 | | Pcstr_tuple cts -> 550 | validate_variant_tuple_exp ~variant_name:cd.pcd_name.txt cts 551 | | Pcstr_record lds -> 552 | validate_variant_record_exp ~variant_name:cd.pcd_name.txt lds 553 | 554 | let validate_variant_exp ~loc cds = 555 | cds 556 | |> List.map validate_constructor_declaration_exp 557 | |> List.flatten |> list_exp ~loc |> validate_keyed_exp ~loc 558 | |> validate_exp ~loc 559 | --------------------------------------------------------------------------------