├── .clj-kondo └── metosin │ └── malli │ └── config.edn ├── .github ├── FUNDING.yml └── workflows │ ├── ci.yml │ └── release.yml ├── .gitignore ├── LICENSE ├── README.md ├── build.clj ├── deps.edn ├── src └── malli_select │ └── core.clj └── test └── malli_select └── core_test.clj /.clj-kondo/metosin/malli/config.edn: -------------------------------------------------------------------------------- 1 | {:lint-as {malli.experimental/defn schema.core/defn} 2 | :linters {:unresolved-symbol {:exclude [(malli.core/=>)]}}} 3 | -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | # These are supported funding model platforms 2 | 3 | github: [eval] 4 | open_collective: eval 5 | custom: ["https://getalby.com/p/eval"] 6 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Run tests 3 | 4 | on: [push, pull_request] 5 | 6 | jobs: 7 | Test: 8 | runs-on: ubuntu-latest 9 | steps: 10 | - name: Check out repository code 11 | uses: actions/checkout@v3 12 | with: 13 | fetch-depth: 0 14 | - name: Install clojure tools 15 | uses: DeLaGuardo/setup-clojure@10.0 16 | with: 17 | cli: latest 18 | - name: Run tests 19 | run: clojure -T:build test 20 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | --- 2 | name: Test, build and (possibly) deploy 3 | 4 | on: 5 | push: 6 | branches: 7 | - main 8 | tags: 9 | - '*' 10 | 11 | jobs: 12 | Release: 13 | runs-on: ubuntu-latest 14 | steps: 15 | - name: Checkout 16 | uses: actions/checkout@v3 17 | with: 18 | fetch-depth: 0 19 | 20 | - name: Install clojure tools 21 | uses: DeLaGuardo/setup-clojure@10.0 22 | with: 23 | cli: latest 24 | 25 | - name: Test, build and (possibly) deploy to clojars 26 | env: 27 | CLOJARS_USERNAME: ${{ secrets.CLOJARS_USERNAME }} 28 | CLOJARS_PASSWORD: ${{ secrets.CLOJARS_PASSWORD }} 29 | run: clojure -T:build release :build/git-version $(printf '"%s"' $(git describe --tags)) :deploy/only-jar-version-type :full-and-snapshot 30 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .calva/output-window/ 2 | .classpath 3 | .clj-kondo/.cache 4 | .cpcache 5 | .eastwood 6 | .factorypath 7 | .hg/ 8 | .hgignore 9 | .java-version 10 | .lein-* 11 | .lsp/.cache 12 | .lsp/sqlite.db 13 | .nrepl-history 14 | .nrepl-port 15 | .portal/vs-code.edn 16 | .project 17 | .rebel_readline_history 18 | .settings 19 | .socket-repl-port 20 | .sw* 21 | .vscode 22 | *.class 23 | *.jar 24 | *.swp 25 | *~ 26 | /checkouts 27 | /classes 28 | /target 29 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Gert Goet, ThinkCreate 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # malli-select 2 | 3 | [![Clojars Project](https://img.shields.io/clojars/v/dk.thinkcreate/malli-select.svg?include_prereleases)](https://clojars.org/dk.thinkcreate/malli-select) [![cljdoc badge](https://cljdoc.org/badge/dk.thinkcreate/malli-select)](https://cljdoc.org/d/dk.thinkcreate/malli-select) 4 | 5 | Create subschemas of [malli](https://github.com/metosin/malli)-schemas using a spec2-inspired select notation. 6 | 7 | It's based on Rich Hickey's ideas from his talk ["Maybe Not"](https://youtu.be/YR5WdGrpoug?feature=shared&t=1965) about how [spec-alpha2](https://github.com/clojure/spec-alpha2) might allow for schema reuse. 8 | 9 | ## Quickstart 10 | 11 | [deps-try](https://github.com/eval/deps-try/blob/master/README.md#installation) has a built-in recipe that walks you through malli-select's features on the REPL ([recipe source](https://github.com/eval/deps-try/blob/master/recipes/malli/malli_select.clj)). 12 | Run like so: 13 | ``` clojure 14 | $ deps-try --recipe malli/malli-select 15 | ``` 16 | 17 | See [the tests](./test/malli_select/core_test.clj) for more. 18 | 19 | 20 | ## LICENSE 21 | 22 | Copyright (c) 2023 Gert Goet, ThinkCreate. 23 | Distributed under the MIT license. See [LICENSE](LICENSE). 24 | -------------------------------------------------------------------------------- /build.clj: -------------------------------------------------------------------------------- 1 | (ns build 2 | "Build malli-select" 3 | (:refer-clojure :exclude [test]) 4 | (:require [clojure.data.xml :as xml] 5 | [clojure.tools.build.api :as b] 6 | [clojure.tools.build.tasks.write-pom :as write-pom] 7 | [deps-deploy.deps-deploy :as dd] 8 | [clojure.java.io :as io])) 9 | 10 | (set! clojure.core/*print-namespace-maps* false) 11 | 12 | ;; Monkey patch to have provided dependencies in the POM 13 | ;; SOURCE https://clojurians.zulipchat.com/#narrow/stream/180378-slack-archive/topic/tools-deps/near/326868214 14 | (xml/alias-uri 'pom "http://maven.apache.org/POM/4.0.0") 15 | 16 | (alter-var-root 17 | #'write-pom/to-dep 18 | (fn [old] 19 | (fn [[_ {:keys [scope]} :as pair]] 20 | (cond-> (old pair) 21 | scope 22 | (conj [::pom/scope scope]))))) 23 | 24 | (def lib 'dk.thinkcreate/malli-select) 25 | 26 | (def class-dir "target/classes") 27 | 28 | (defn- extract-keys-with-ns 29 | "E.g. `{:test/H true :foo :bar} ;;=> {:H true}`" 30 | [ns m] 31 | (update-keys (filter (comp #(= (name ns) %) namespace key) m) 32 | (comp keyword name))) 33 | 34 | (defn ^#:fika{:examples [":test/d '\"some-dir\"'" 35 | ":test/n '\"some.namespace-test\"'" 36 | "# see all runner options\n:test/H true"]} 37 | test 38 | "Run all the tests. 39 | 40 | Passing options to test-runner possible, see examples." [opts] 41 | #_(prn :opts opts) 42 | (let [test-options (extract-keys-with-ns "test" opts) 43 | test-options (-> test-options 44 | (update-keys (fn [k] 45 | ;; :H => "-H", :help => "--help" 46 | (let [k (name k)] 47 | (cond->> (str "-" k) 48 | (> (count k) 1) (str "-"))))) 49 | (update-vals str)) 50 | basis (b/create-basis {:aliases [:test]}) 51 | cmds (doto (b/java-command 52 | {:basis basis 53 | :main 'clojure.main 54 | #_#_:cp ["/opt/homebrew/Cellar/clojure/1.11.1.1413/libexec/exec.jar"] 55 | #_#_:main-args ["-m" "clojure.run.exec" ":dirs" "src"] 56 | :main-args (doto (reduce into ["-m" "cognitect.test-runner"] test-options) prn)})) 57 | {:keys [exit]} (b/process cmds)] 58 | (when-not (zero? exit) (throw (ex-info "Tests failed" {})))) 59 | opts) 60 | 61 | (b/java-command {:basis (b/create-basis {:aliases [:test]}) :main 'clojure.main}) 62 | (defn- pom-template [version version-type] 63 | [[:description "spec2-inspired selection of Malli schemas"] 64 | [:url "https://github.com/eval/malli-select"] 65 | [:licenses 66 | [:license 67 | [:name "MIT"] 68 | [:url "https://github.com/eval/malli-select/blob/main/LICENSE"]]] 69 | [:developers 70 | [:developer 71 | [:name "Gert Goet (@eval)"]]] 72 | (cond-> [:scm 73 | [:url "https://github.com/eval/malli-select"] 74 | [:connection "scm:git:https://github.com/eval/malli-select.git"] 75 | [:developerConnection "scm:git:ssh:git@github.com:eval/malli-select.git"]] 76 | (= :exact version-type) (conj [:tag (str "v" version)]))]) 77 | 78 | 79 | (defn- jar-opts [{:keys [version version-type] :as opts}] 80 | (assoc opts 81 | :lib lib :version version 82 | :jar-file (format "target/%s-%s.jar" lib version) 83 | :basis (b/create-basis {}) 84 | :class-dir class-dir 85 | :target "target" 86 | :src-dirs ["src"] 87 | :pom-data (pom-template version version-type))) 88 | 89 | (defn- git-version->version&type 90 | "`git-version` typically output of `git describe --tags`, 91 | e.g. `v1.2.3`, `v1.2.3-pre.1` or `v1.2.3-1-g`. 92 | Yields map with `version` and `type`." 93 | [git-version] 94 | (let [type (condp re-find git-version 95 | #"^v\d+\.\d+\.\d+$" :exact 96 | #"^v\d+\.\d+\.\d+-pre\.\d+" :pre ;; pre-tag and any commit after 97 | :build) 98 | exact-version (second (re-find #"v(\d+\.\d+\.\d+)" git-version)) 99 | version (case type 100 | :exact exact-version 101 | :pre (str exact-version "-SNAPSHOT") 102 | :build (subs git-version 1))] 103 | {:version version :version-type type})) 104 | 105 | (comment 106 | (git-version->version&type "v1.2.3-123") 107 | 108 | #_:end) 109 | 110 | (defn 111 | ^#:fika{:examples [":build/git-version $(printf '\"%s\"' $(git describe --tags))"] 112 | :option.git-version {:name :build/git-version 113 | :desc "Output of `git describe --tags`, e.g. \"v1.2.3\", \"v1.2.3-pre.1\""}} 114 | build 115 | "Build the JAR." 116 | [{:build/keys [git-version] :as opts}] 117 | {:pre [(let [git-version-re #"^v\d+\.\d+\.\d+"] 118 | (or (and git-version (re-find git-version-re git-version)) 119 | (throw (ex-info (str "requires :build/git-version with value matching " (pr-str git-version-re) ", e.g. :build/git-version '\"v1.2.3\"\"'") {}))))]} 120 | (let [opts (merge opts (git-version->version&type git-version))] 121 | (b/delete {:path "target"}) 122 | (let [opts (jar-opts opts)] 123 | (println "\nWriting pom.xml...") 124 | (b/write-pom opts) 125 | (println "\nCopying source...") 126 | (b/copy-dir {:src-dirs ["resources" "src"] :target-dir class-dir}) 127 | (println "\nBuilding JAR..." (:jar-file opts)) 128 | (b/jar opts)) 129 | opts)) 130 | 131 | (defn- pom-path->version [pom-path] 132 | (->> (io/reader pom-path) 133 | xml/parse 134 | :content 135 | (filter map?) 136 | (filter (comp #(= "version" %) name :tag)) 137 | first 138 | :content 139 | first)) 140 | 141 | (defn 142 | ^#:fika{:option.only-jar-version-type 143 | {:name "deploy/only-jar-version-type" 144 | :desc "Deploy the built jar based on the type of version it has. One of :full (default, e.g. \"1.2.3\"), :full-and-snapshot (also jar-versions like \"1.2.3-SNAPSHOT\"), :all (any jar that was built)."}} 145 | deploy 146 | "Deploy the built jar." 147 | [{:deploy/keys [only-jar-version-type] :or {only-jar-version-type :full} :as opts}] 148 | {:pre [(#{:full-and-snapshot :full :all} only-jar-version-type)]} 149 | (let [{:keys [jar-file] :as opts} (jar-opts opts) 150 | pom-file (b/pom-path (select-keys opts [:lib :class-dir])) 151 | version (pom-path->version pom-file) 152 | [v s] (re-find #"^\d+\.\d+\.\d+(-SNAPSHOT)?$" version) 153 | deploy? (or (= :all only-jar-version-type) 154 | (and (= :full-and-snapshot only-jar-version-type) v) 155 | (and (= :full only-jar-version-type) 156 | v 157 | (not s)))] 158 | (if deploy? 159 | (dd/deploy {:installer :remote 160 | :artifact (b/resolve-path jar-file) 161 | :pom-file pom-file}) 162 | (println (str \newline "Skipping deploy of version " version " given only-jar-release-type " only-jar-version-type))) 163 | opts)) 164 | 165 | 166 | (defn ^#:fika{:examples [":build/git-version '\"v1.2.3\"'" 167 | ":build/git-version $(printf '\"%s\"' $(git describe --tags))" 168 | ":build/git-version '\"v1.2.3\"' :deploy/only-jar-version-type :full-and-snapshot"] 169 | 170 | :options.from-commands '[test build deploy]} 171 | release 172 | "Test, build and deploy. 173 | 174 | Deploys *only* when name of the jar built has the right format, see option `deploy/only-jar-version-type`." 175 | [opts] 176 | #_(prn :release-opts opts) 177 | (deploy (build (test opts)))) 178 | 179 | (comment 180 | 181 | 182 | (def jopts (jar-opts {})) 183 | jopts 184 | 185 | #_:end) 186 | -------------------------------------------------------------------------------- /deps.edn: -------------------------------------------------------------------------------- 1 | {:paths ["src"] 2 | :deps {org.clojure/clojure {:mvn/version "1.11.1" :scope "provided"} 3 | metosin/malli {:mvn/version "0.13.0" :scope "provided"}} 4 | :aliases 5 | {:dev {:extra-deps {metosin/malli {:mvn/version "0.8.9"} 6 | criterium/criterium {:mvn/version "0.4.6"} 7 | com.clojure-goes-fast/clj-async-profiler {:mvn/version "1.0.5"}}} 8 | :neil {:project {:name malli-select/malli-select}} 9 | 10 | :malli-0.9 11 | {:override-deps {metosin/malli {:mvn/version "0.9.2"}}} 12 | 13 | :malli-0.10 14 | {:override-deps {metosin/malli {:mvn/version "0.10.4"}}} 15 | 16 | :malli-0.11 17 | {:override-deps {metosin/malli {:mvn/version "0.11.0"}}} 18 | 19 | :malli-0.12 20 | {:override-deps {metosin/malli {:mvn/version "0.12.0"}}} 21 | 22 | :test ;; added by neil 23 | {:extra-paths ["test"] 24 | :extra-deps {metosin/malli {:mvn/version "0.8.9"} 25 | io.github.cognitect-labs/test-runner {:git/tag "v0.5.1" :git/sha "dfb30dd"}} 26 | :exec-fn cognitect.test-runner.api/test} 27 | :perf {#_#_:extra-paths ["perf"] 28 | :extra-deps {criterium/criterium {:mvn/version "0.4.6"} 29 | org.clojure/clojure {:mvn/version "1.11.1"} 30 | com.clojure-goes-fast/clj-async-profiler {:mvn/version "1.0.5"}} 31 | :jvm-opts ["-server" 32 | "-Xmx4096m" 33 | "-Dclojure.compiler.direct-linking=true" 34 | "-Djdk.attach.allowAttachSelf"]} 35 | :build {:deps {io.github.clojure/tools.build 36 | {:mvn/version "0.9.6"} 37 | slipset/deps-deploy {:mvn/version "0.2.1"}} 38 | :ns-default build}}} 39 | -------------------------------------------------------------------------------- /src/malli_select/core.clj: -------------------------------------------------------------------------------- 1 | (ns malli-select.core 2 | "Select a subset of a malli schema." 3 | (:require [clojure.pprint :refer [pprint]] 4 | [malli.core :as m] 5 | [malli.util :as mu])) 6 | 7 | (defn- clean-path [path] 8 | (loop [p path 9 | r (transient [])] 10 | (if-not (seq p) 11 | (persistent! r) 12 | (recur (rest p) (let [phead (first p)] 13 | (if (#{0 1 :malli.core/in} phead) 14 | r 15 | (conj! r phead))))))) 16 | 17 | 18 | (defn- map-schema-path-walker [f] 19 | (fn [schema path children _] 20 | (let [schema (m/-set-children schema children) 21 | map-schema? (= :map (m/type schema))] 22 | (cond-> schema 23 | map-schema? (f path))))) 24 | 25 | 26 | (defn- sel->map 27 | "Turns `[:a {:b [:c]} {:b [:d]} :e]` 28 | into `{nil [:a :e] :b [:d]}` (i.e. last `:b` wins)." 29 | [sel] 30 | (persistent! (reduce (fn [acc i] 31 | (if (map? i) 32 | (reduce conj! acc i) 33 | (assoc! acc nil (conj (get acc nil) i)))) (transient {}) sel))) 34 | 35 | 36 | (defn- parse-selection 37 | "Examples: 38 | ``` 39 | (parse-selection []) ;; => [['?]] 40 | (parse-selection [:name]) ;; => [[:name]] 41 | (parse-selection [:name {:address [:street]}]) ;; => [[:name] [:address :street]] 42 | ``` 43 | " 44 | ([sel] (parse-selection sel [])) 45 | ([sel path] 46 | (if-not (seq sel) 47 | [(conj path '?)] 48 | (let [sel-map (sel->map sel)] 49 | (persistent! 50 | (reduce-kv (fn [acc k v] 51 | (if (nil? k) 52 | (reduce conj! acc (map #(conj path %) v)) 53 | (reduce conj! acc (parse-selection v (conj path k))))) (transient []) sel-map)))))) 54 | 55 | 56 | (defn- paths->tree [paths] 57 | (reduce (fn [acc path] 58 | (let [[folder name] ((juxt pop peek) path)] 59 | (update acc folder (fnil conj #{}) name))) {} paths)) 60 | 61 | 62 | (defn selectable-paths 63 | "Yield set of selectable paths. 64 | 65 | Examples: 66 | ``` 67 | (selectable-paths 68 | [:maybe 69 | [:map 70 | [:addresses [:vector [:map 71 | [:street string?]]]]]]) 72 | ;;=> #{[:addresses] [:addresses :street]} 73 | ``` 74 | " 75 | [schema] 76 | (->> schema 77 | mu/subschemas 78 | (map (comp clean-path :path)) 79 | (filter seq) 80 | set)) 81 | 82 | 83 | (defn- -select 84 | [schema selection 85 | {:as _options 86 | ::keys [optionalized] 87 | :keys [verify-selection prune-optionals] 88 | :or 89 | {verify-selection :assert}}] 90 | (letfn [(in? [coll elm] 91 | (some #(= % elm) coll))] 92 | (let [all-optional? (empty? selection) 93 | verify-selection? (and (not (in? #{nil false :skip} verify-selection)) 94 | (not all-optional?)) 95 | prune-optionals (if (not (nil? prune-optionals)) 96 | prune-optionals 97 | (-> selection meta :only)) 98 | selection-paths (parse-selection selection) 99 | sel-map (paths->tree selection-paths) 100 | !available-paths (atom #{}) 101 | !seen (atom #{}) 102 | record-seen! (fn [schema path to-require] 103 | (when verify-selection? 104 | (let [available-keys (map first (m/entries schema)) 105 | valid-keys (into ['? '*] available-keys) 106 | seen-keys (filter to-require valid-keys)] 107 | (swap! !available-paths into 108 | (map (partial conj path) available-keys)) 109 | (swap! !seen into 110 | (map (partial conj path) seen-keys))))) 111 | !prune-exclusions (atom #{}) 112 | record-prune-exclusions! (fn [path] 113 | (when prune-optionals 114 | (let [self&parent-paths (take (inc (count path)) (iterate pop path))] 115 | (swap! !prune-exclusions into self&parent-paths)))) 116 | 117 | walker (let [optionalize-step (fn optionalize-step [v] 118 | (update v 0 mu/optional-keys)) 119 | require-step (fn require-step [[schema path :as v]] 120 | (let [cleaned-path (clean-path path) 121 | to-require (sel-map cleaned-path)] 122 | (if-not (seq to-require) 123 | v 124 | (let [star? (some #{'*} to-require)] 125 | (record-seen! schema cleaned-path to-require) 126 | (record-prune-exclusions! path) 127 | (update v 0 128 | #(if star? 129 | (mu/required-keys %) 130 | (mu/required-keys % to-require))))))) 131 | 132 | prune-step (fn prune-step [[schema path :as v]] 133 | (let [prunable? (every-pred (comp :optional second) 134 | (comp not @!prune-exclusions #(conj path %) first)) 135 | children (remove prunable? (m/children schema))] 136 | (update v 0 #(m/into-schema (m/type %) (m/-properties %) 137 | children (m/-options %))))) 138 | wrap (fn [stack step] 139 | #(step (stack %))) 140 | middlewares (cond-> identity 141 | (not optionalized) (wrap optionalize-step) 142 | (not all-optional?) (wrap require-step) 143 | prune-optionals (wrap prune-step) 144 | :finally (wrap first))] 145 | (map-schema-path-walker (comp middlewares vector))) 146 | walked (m/walk schema walker 147 | {::m/walk-schema-refs true ::m/walk-refs true})] 148 | (when verify-selection? 149 | (let [invalid-selection-paths (remove @!seen selection-paths)] 150 | (assert (empty? invalid-selection-paths) 151 | (str "Selection contains unknown paths: " (prn-str invalid-selection-paths) 152 | "\nAvailable: \n" (with-out-str (pprint (sort (selectable-paths schema)))))))) 153 | 154 | walked))) 155 | 156 | 157 | (defn select 158 | "`selection` examples: 159 | - `[]` - everything (deep) optional 160 | - `[:name :age]` - required attributes 161 | - `['*]` - everything (non-recursive) required 162 | - `[{:address [:street]}]` - if `:address` provided then only `:street` is required. 163 | 164 | Combinations: 165 | - `[:address {:address [:street]}]` - require `:address` but only its `:street` is required. 166 | - `[:address {:address [] :friends [:name]}]` - require `:address` and optionally `:friends`. 167 | - `[{:friends [:name]} {:friends [:age]}]` - only require `:age` of friends if `:friends` provided (last selection wins). 168 | 169 | `options`: 170 | - `verify-selection` (`:assert` (default), `:skip`, `false`, `nil`) - what to do when `selection` contains paths not in `schema`. 171 | - `prune-optionals` (`false` (default), `true`) - whether all fully optional subtrees should be removed from the resulting schema. Alternatively via metadata of selection: `^:only [:name]` (flag takes precedence over metadata). 172 | Typically used when the selected schema is used for data generation. 173 | 174 | Examples: 175 | ``` 176 | (select Person) ;; all optional 177 | (select Person []) ;; all optional 178 | (select Person ['*]) ;; all root attributes of Person required 179 | (select Person [:name :handle]) ;; Require specific root attributes. 180 | (select Person [{:address ['*]}]) ;; Require the full address if provided. 181 | 182 | (select Person [:foo]) ;; Assert exception about non existing path, showing all possible paths. 183 | ``` 184 | " 185 | ([schema] 186 | (select schema [] nil)) 187 | ([schema selection] 188 | (select schema selection nil)) 189 | ([schema selection {:as options 190 | :keys [verify-selection prune-optionals] 191 | :or {verify-selection :assert}}] 192 | (-select schema selection (assoc options 193 | :verify-selection verify-selection 194 | :prune-optionals prune-optionals)))) 195 | 196 | 197 | (defn selector 198 | "Yields a function similar to `(partial ms/select schema)`. 199 | A selector is faster when doing multiple selections from a schema as the schema is optionalized once. 200 | 201 | Examples: 202 | ``` 203 | (let [person-selector (selector Person)] 204 | (person-selector ^:only [:name])) 205 | ``` 206 | " 207 | [schema] 208 | (let [optionalized-schema (select schema)] 209 | (fn selector-select 210 | ([selection] (selector-select selection nil)) 211 | ([selection options] 212 | (-select optionalized-schema selection (merge {::optionalized true} options)))))) 213 | 214 | (comment 215 | (def Person 216 | [:map 217 | [:name string?] 218 | [:age int?] 219 | [:friends [:vector [:map [:name string?]]]] 220 | [:addresses [:vector [:map 221 | [:street string?] 222 | [:country string?]]]]]) 223 | 224 | (let [person-selector (selector Person)] 225 | (m/form (person-selector [:name] {:prune-optionals true}))) 226 | 227 | (let [schema [:schema {:registry {"More" [:map 228 | [:more boolean?]] 229 | "Other" [:map 230 | [:other boolean?] 231 | [:more "More"]]}} 232 | [:map 233 | [:this boolean?] 234 | [:that "Other"]]] 235 | selector (selector schema)] 236 | (cc/quick-bench (selector ^:only [:this {:that ['*]}])) 237 | #_(cc/quick-bench (selector schema))) 238 | 239 | (require '[criterium.core :as cc]) 240 | 241 | 242 | (cc/quick-bench (select Person ^:only [:name])) 243 | 244 | (def person-selector (selector Person)) 245 | (cc/quick-bench (selector Person)) ;; 10us 246 | (cc/quick-bench (select Person ^:only [:name {:addresses [:street]}])) ;; 23us 247 | (cc/quick-bench (person-selector ^:only [:name {:addresses [:street]}])) ;; 13us 248 | 249 | (m/form (select [:maybe Person] ^:only [:name {:friends [:name]}])) 250 | 251 | 252 | #_:end) 253 | -------------------------------------------------------------------------------- /test/malli_select/core_test.clj: -------------------------------------------------------------------------------- 1 | (ns malli-select.core-test 2 | (:require 3 | [clojure.pprint :refer [pprint]] 4 | [clojure.test :as t :refer [deftest is testing]] 5 | [malli-select.core :as sut :refer [select selector]] 6 | [malli.core :as m] 7 | [malli.util :as mu])) 8 | 9 | (defonce ^:private ^:dynamic 10 | *schema* nil) 11 | 12 | (defonce ^:private ^:dynamic 13 | *selector* nil) 14 | 15 | (defn pps [o] 16 | (with-out-str (pprint o))) 17 | 18 | (defmacro expect-selection-to-validate [sel & data+maybe-reason] 19 | `(if ~sel 20 | (let [data# ~(first data+maybe-reason) 21 | sel-schema# (if *selector* (*selector* ~sel) (select *schema* ~sel (meta ~sel))) 22 | result# (or (m/validate sel-schema# data#) (m/explain sel-schema# data#))] 23 | (is (true? result#) 24 | (cond-> (str "Expected data:\n" (pps data#) "to be valid given schema:\n" (pps (m/form sel-schema#))) 25 | ~(second data+maybe-reason) (str "because:\n" ~(second data+maybe-reason)) 26 | :always (str "\nvalidate errors:\n" (pps (:errors result#)))))) 27 | *schema*)) 28 | 29 | (defmacro expect-selection-to-invalidate [sel & data+maybe-reason] 30 | `(if ~sel 31 | (let [data# ~(first data+maybe-reason) 32 | sel-schema# (if *selector* (*selector* ~sel) (select *schema* ~sel (meta ~sel)))] 33 | (is (false? (m/validate sel-schema# data#)) 34 | (cond-> (str "Expected data:\n" (pps data#) "to be *invalid* given schema:\n" (pps (m/form sel-schema#))) 35 | ~(second data+maybe-reason) (str "because:\n" ~(second data+maybe-reason))))) 36 | *schema*)) 37 | 38 | 39 | (deftest select-test 40 | (testing "common selections" 41 | (let [S1 [:map 42 | [:name string?] 43 | [:handle string?] 44 | [:address [:maybe [:map 45 | [:street string?] 46 | [:zip int?] 47 | [:country [:map-of 48 | string? [:map 49 | [:iso string?] [:name string?]]]]]]] 50 | [:roles [:set [:map 51 | [:name string?]]]]]] 52 | (testing "all optional" 53 | (binding [*schema* S1] 54 | (expect-selection-to-validate [] {}) 55 | (expect-selection-to-validate [] {:address {:country {}}}) 56 | (expect-selection-to-invalidate [] {:address {:country {:dk {}}}} 57 | "types should still match"))) 58 | 59 | (testing "root attributes" 60 | (binding [*schema* S1] 61 | (expect-selection-to-invalidate [:name] {}) 62 | (expect-selection-to-validate [:name] {:name "Gert"}) 63 | (expect-selection-to-invalidate [:handle :name] {:name "Gert"}) 64 | (expect-selection-to-validate [:name :handle] {:name "Gert" :handle "eval"}) 65 | (expect-selection-to-invalidate [:address] {} 66 | ":address required") 67 | (expect-selection-to-validate [:address] {:address nil} 68 | ":address key provided - nothing needed from address")) 69 | 70 | ;; wrapped 71 | (binding [*schema* [:maybe [:vector S1]]] 72 | (expect-selection-to-validate nil nil "normal malli behavior") 73 | (expect-selection-to-validate nil [{}] "normal malli behavior") 74 | (expect-selection-to-invalidate [:name] [{}]) 75 | (expect-selection-to-validate [:name] [{:name "Gert"}]) 76 | (expect-selection-to-invalidate [:handle :name] [{:name "Gert"}]) 77 | (expect-selection-to-validate [:name :handle] [{:name "Gert" :handle "eval"}]))) 78 | 79 | (testing "nested attributes" 80 | (binding [*schema* S1] 81 | (expect-selection-to-validate [{:address [:street]}] {} ":address not provided") 82 | (expect-selection-to-invalidate [{:address [:street]}] {:address {}}) 83 | (expect-selection-to-invalidate [:address {:address [:street]}] {}) 84 | 85 | (expect-selection-to-validate [:address {:address [:street]}] {:address {:street "Main"}} 86 | "the root :address should not interfere with the nested selection") 87 | (expect-selection-to-validate [{:address [:street]} :address] {:address {:street "Main"}} 88 | "order of items should not matter here") 89 | 90 | ;; star selection 91 | (expect-selection-to-validate [{:address ['*]}] {} ":address not provided") 92 | (expect-selection-to-invalidate [{:address ['*]}] {:address {:street "Main"}}) 93 | (expect-selection-to-validate [{:address ['*]}] {:address {:street "Main" 94 | :zip 1234 95 | :country {}}} 96 | "all keys of address-map should be required - contents of country optional!") 97 | (expect-selection-to-validate [{:address ['* {:country []}]}] 98 | {:address {:street "Main" 99 | :zip 1234 100 | :country {}}} 101 | "override star-selection: country-content is optional") 102 | 103 | ;; selecting through a set 104 | (expect-selection-to-validate [{:roles [:name]}] {:roles #{}} "no role provided") 105 | (expect-selection-to-invalidate [{:roles [:name]}] {:roles #{{}}}) 106 | (expect-selection-to-validate [{:roles [:name]}] {:roles #{{:name "Admin"}}}) 107 | 108 | (expect-selection-to-validate [{:address [:street]} {:address [:zip]}] {:address {:zip 1234}} 109 | "last selection of :address wins") 110 | 111 | (expect-selection-to-invalidate [{:address [:street] :roles [:name]} 112 | {:address [:zip]}] 113 | {:address {:zip 1234} :roles [{}]} 114 | "selection maps are merged") 115 | (expect-selection-to-validate [{:address [:street] :roles [:name]} 116 | {:address [:zip]}] 117 | {:address {:zip 1234} :roles #{{:name "Admin"}}} 118 | "[:address :street] is overridden by [:address :zip]") 119 | 120 | (expect-selection-to-validate [{:address [{:country [:name]}]}] 121 | {:address {:country {"DK" {:name "Denmark"}}}} 122 | "multi-level nesting"))))) 123 | (testing "schema with refs" 124 | (let [S1 [:schema {:registry {"Other" [:map 125 | [:other boolean?]]}} 126 | [:map 127 | [:this boolean?] 128 | [:that "Other"]]]] 129 | 130 | (testing "marking all optional" 131 | (binding [*schema* S1] 132 | (expect-selection-to-validate [] {}) 133 | (expect-selection-to-validate [] {:that {}} "it should walk refs"))) 134 | 135 | (testing "star selections" 136 | (binding [*schema* (select S1 [])] ;; ensure all optional 137 | (expect-selection-to-invalidate ['*] {}) 138 | (expect-selection-to-validate ['*] {:this true :that {}}) 139 | (expect-selection-to-invalidate [{:that ['*]}] {:that {}} 140 | "it should walk refs and require all keys from Other") 141 | (expect-selection-to-validate [{:that ['*]}] {:that {:other true}} 142 | "it has all keys of Other-schema"))))) 143 | 144 | (testing "options" 145 | (testing "prune-optionals" 146 | (testing "common" 147 | (binding [*schema* [:map 148 | [:name string?] 149 | [:age int?] 150 | [:addresses [:maybe [:vector [:map 151 | [:street string?] 152 | [:zip int?]]]]]]] 153 | (expect-selection-to-validate ^:only [:name] 154 | {:name "Gert" :age "N/A" :addresses 1} 155 | ":age can now be anything as it's no longer part of the schema") 156 | (expect-selection-to-invalidate ^:only [{:addresses [:street]}] 157 | {:addresses [{}]} 158 | "optional :addresses doesn't trigger a deep prune") 159 | (expect-selection-to-validate ^:only [:addresses {:addresses [:street]}] 160 | {:addresses [{:street "Main"}]}))) 161 | (testing "optionals with aggregates" 162 | (binding [*schema* [:maybe [:map 163 | [:address [:map [:street string?]]] 164 | [:friends [:maybe [:vector [:map [:name string?]]]]] 165 | [:countries [:map-of string? [:map [:name string?]]]]]]] 166 | (expect-selection-to-validate ^:only [] 167 | {:countries 1} 168 | ":countries is no longer part of schema") 169 | (expect-selection-to-invalidate ^:only [:countries] 170 | {:countries 1} 171 | ":countries should require a map-of string map") 172 | (expect-selection-to-invalidate ^:only [:countries] 173 | {:countries {"foo" 1}} 174 | ":countries should require a map-of string map") 175 | (expect-selection-to-validate ^:only [:countries] 176 | {:countries {"foo" {}}} 177 | ":countries is no longer part of the schema") 178 | 179 | (expect-selection-to-validate ^:only [:friends] 180 | {:friends [{}]} 181 | ":friends requires just a vector of maps") 182 | (expect-selection-to-invalidate ^:only [:friends] 183 | {:friends [1]} 184 | ":friends requires just a vector of maps"))) 185 | (testing "schema with refs" 186 | (binding [*schema* [:schema {:registry {"Other" [:map 187 | [:other boolean?]]}} 188 | [:map 189 | [:this boolean?] 190 | [:that "Other"]]]] 191 | (expect-selection-to-validate ^:only [] 192 | {:that {:other "?"}} 193 | ":other can be a string as it should no longer be part of the schema")))) 194 | (testing "verify-selection" 195 | (is (thrown-with-msg? AssertionError #"unknown paths: \(\[:a\]\)" 196 | (select int? [:a]))) 197 | (testing "disabling it" 198 | (is (some? (select int? [:a] {:verify-selection :skip}))) 199 | (is (some? (select int? [:a] {:verify-selection nil}))))))) 200 | 201 | (deftest selector-test 202 | (binding [*selector* (selector [:map 203 | [:name string?] 204 | [:age int?] 205 | [:addresses [:maybe [:vector [:map 206 | [:street string?] 207 | [:zip int?]]]]]])] 208 | (expect-selection-to-validate [:name] 209 | {:name "Foo"} 210 | "All but :name optional") 211 | (expect-selection-to-invalidate [:name] 212 | {:name "Foo" :age "NaN"} 213 | "All but :name optional"))) 214 | 215 | (comment 216 | (select [:map [:address [:map [:street string?]]]] [{:address [:street]}] {:prune-optionals true}) 217 | 218 | (mu/update-properties :map assoc :closed true) 219 | (m/validate [:map {:closed true}] {}) 220 | ) 221 | --------------------------------------------------------------------------------