Add string schema properties

src/malli/core.cljc

@@ -570,6 +570,79 @@
   (when-let [ns-name (some-> properties :namespace name)]
     (fn [x] (= (namespace x) ns-name))))
 
+;;
+;; string schema helpers
+;;
+
+#?(:cljs (defn -numeric-char? [c] (and (< 47 c) (< c 58))))
+#?(:cljs (defn -upper-alpha-char? [c] (and (< 64 c) (< c 91))))
+#?(:cljs (defn -lower-alpha-char? [c] (and (< 96 c) (< c 123))))
+#?(:cljs (defn -letter? [c] (or (-lower-alpha-char? c) (-upper-alpha-char? c))))
+#?(:cljs (defn -alphanumeric? [c] (or (-letter? c) (-numeric-char? c))))
+
+(defn -charset-predicate
+  [o]
+  (case o
+    :digit #?(:clj #(Character/isDigit ^char %) :cljs -numeric-char?)
+    :letter #?(:clj #(Character/isLetter ^char %) :cljs -letter?)
+    (:alphanumeric :letter-or-digit) #?(:clj #(Character/isLetterOrDigit ^char %) :cljs -alphanumeric?)
+    :alphabetic #?(:clj #(Character/isAlphabetic (int %)) :cljs -letter?)
+    (cond
+      (set? o) (miu/-some-pred (mapv -charset-predicate o))
+      (char? o) #?(:clj #(= ^char o %) :cljs (let [i (.charCodeAt o 0)] #(= i %)))
+      :else (eval o))))
+
+(defn string-char-predicate
+  [p]
+  (fn charset-pred ^Boolean [^String s]
+    (let [n #?(:clj (.length s) :cljs (.-length s))]
+      (loop [i 0]
+        (if (= i n)
+          true
+          (if (p #?(:clj  (.charAt s (unchecked-int i))
+                    :cljs (.charCodeAt s (unchecked-int i))))
+            (recur (unchecked-inc i))
+            false))))))
+
+#?(:clj
+   (defn find-blank-method
+     []
+     (try
+       (.getMethod String "isBlank" (into-array Class []))
+       #(.isBlank ^String %)
+       (catch Exception _
+         (require 'clojure.string)
+         clojure.string/blank?))))
+
+#?(:clj  (def blank? (find-blank-method))
+   :cljs (defn blank? [^String s] (zero? (.-length (.trim s)))))
+
+(defn -string-predicates
+  ([{:keys [charset pattern non-blank]}]
+   (let [pattern
+         (when pattern
+           (let [pattern (re-pattern pattern)]
+             #?(:clj #(.find (.matcher ^Pattern pattern ^String %))
+                :cljs #(boolean (re-find pattern %)))))
+         charset
+         (when charset
+           (let [p (-charset-predicate charset)]
+             (string-char-predicate p)))
+         non-blank (when non-blank #(not (blank? %)))]
+     (-> non-blank
+         (miu/-maybe-and charset)
+         (miu/-maybe-and pattern)))))
+
+(defn -string-property-pred
+  []
+  (fn [properties]
+    (miu/-maybe-and
+     ((-min-max-pred
+       #?(:clj #(.length ^String %)
+          :cljs #(.-length ^String %)))
+      properties)
+     (-string-predicates properties))))
+
 ;;
 ;; Schemas
 ;;
@@ -625,7 +698,7 @@
 
 (defn -nil-schema [] (-simple-schema {:type :nil, :pred nil?}))
 (defn -any-schema [] (-simple-schema {:type :any, :pred any?}))
-(defn -string-schema [] (-simple-schema {:type :string, :pred string?, :property-pred (-min-max-pred count)}))
+(defn -string-schema [] (-simple-schema {:type :string, :pred string?, :property-pred (-string-property-pred)}))
 (defn -int-schema [] (-simple-schema {:type :int, :pred int?, :property-pred (-min-max-pred nil)}))
 (defn -double-schema [] (-simple-schema {:type :double, :pred double?, :property-pred (-min-max-pred nil)}))
 (defn -boolean-schema [] (-simple-schema {:type :boolean, :pred boolean?}))

src/malli/generator.cljc

@@ -36,14 +36,45 @@
 
 (defn- -double-gen [options] (gen/double* (merge {:infinite? false, :NaN? false} options)))
 
-(defn- -string-gen [schema options]
-  (let [{:keys [min max]} (-min-max schema options)]
+(def ^:private char-numeric (gen/fmap char (gen/choose 48 57)))
+
+(defn- -char-gen
+  [k]
+  (case k
+    :digit char-numeric
+    :letter gen/char-alpha
+    (:alphanumeric :letter-or-digit) gen/char-alphanumeric
     (cond
-      (and min (= min max)) (gen/fmap str/join (gen/vector gen/char min))
-      (and min max) (gen/fmap str/join (gen/vector gen/char min max))
-      min (gen/fmap str/join (gen/vector gen/char min (* 2 min)))
-      max (gen/fmap str/join (gen/vector gen/char 0 max))
-      :else gen/string-alphanumeric)))
+      (set? k)
+      (let [chars (into [] (filter char? k))
+            chars (gen/fmap chars (gen/choose 0 (dec (count chars))))
+            gens (into [] (comp (remove char?) (map -char-gen)) k)]
+        (gen/one-of (conj gens chars))))))
+
+#?(:clj
+   (defn- -string-from-regex [re]
+     (if-let [string-from-regex @(dynaload/dynaload 'com.gfredericks.test.chuck.generators/string-from-regex {:default nil})]
+       (string-from-regex (re-pattern (str/replace (str re) #"^\^?(.*?)(\$?)$" "$1")))
+       (m/-fail! :test-chuck-not-available))))
+
+(defn- -string-gen [schema options]
+  (let [{:keys [min max]} (-min-max schema options)
+        {:keys [charset pattern non-blank]
+         :or {charset :alphanumeric}} (m/properties schema options)
+        min (cond
+              (and min non-blank) (clojure.core/max min non-blank)
+              non-blank 1
+              min min)]
+    (if pattern
+      #?(:clj (-string-from-regex pattern) :cljs (m/-fail! ::unsupported-generator))
+      (let [seed (-char-gen charset)
+            gen (cond
+                  (and min (= min max)) (gen/vector seed min)
+                  (and min max) (gen/vector seed min max)
+                  min (gen/vector seed min (* 2 min))
+                  max (gen/vector seed 0 max)
+                  :else (gen/vector seed))]
+        (gen/fmap str/join gen)))))
 
 (defn- -coll-gen [schema f options]
   (let [{:keys [min max]} (-min-max schema options)
@@ -101,10 +132,8 @@
 #?(:clj
    (defn -re-gen [schema options]
      ;; [com.gfredericks/test.chuck "0.2.10"+]
-     (if-let [string-from-regex @(dynaload/dynaload 'com.gfredericks.test.chuck.generators/string-from-regex {:default nil})]
-       (let [re (or (first (m/children schema options)) (m/form schema options))]
-         (string-from-regex (re-pattern (str/replace (str re) #"^\^?(.*?)(\$?)$" "$1"))))
-       (m/-fail! :test-chuck-not-available))))
+     (let [re (or (first (m/children schema options)) (m/form schema options))]
+       (-string-from-regex re))))
 
 (defn -ref-gen [schema options]
   (let [gen* (delay (generator (m/deref-all schema) options))]

src/malli/impl/util.cljc

@@ -65,3 +65,10 @@
 (def ^{:arglists '([[& preds]])} -some-pred
   #?(:clj (-pred-composer or 16)
      :cljs (fn [preds] (fn [x] (boolean (some #(% x) preds))))))
+
+(defn -maybe-and
+  [f g]
+  (cond
+    (and f g) #(and (f %) (g %))
+    f f
+    g g))

src/malli/json_schema.cljc

@@ -136,7 +136,18 @@
 (defmethod accept :nil [_ _ _ _] {:type "null"})
 
 (defmethod accept :string [_ schema _ _]
-  (merge {:type "string"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minLength, :max :maxLength}))))
+  (let [props (-> schema m/properties)
+        pattern (case (:charset props)
+                  :digit "^[0-9]*$"
+                  :letter "^[a-zA-Z]*$"
+                  (:alphanumeric :letter-or-digit) "^[a-zA-Z0-9]*$"
+                  nil)
+        props (cond-> props pattern (assoc :pattern pattern))]
+    (merge
+     {:type "string"}
+     (-> props
+         (select-keys [:min :max :pattern])
+         (set/rename-keys {:min :minLength, :max :maxLength})))))
 
 (defmethod accept :int [_ schema _ _]
   (merge {:type "integer"} (-> schema m/properties (select-keys [:min :max]) (set/rename-keys {:min :minimum, :max :maximum}))))

test/malli/core_test.cljc

@@ -2622,3 +2622,44 @@
   (is (= ["1"] (m/-vmap str (subvec [1 2] 0 1))))
   (is (= ["1"] (m/-vmap str (lazy-seq [1]))))
   (is (= ["1" "2"] (m/-vmap str [1 2]))))
+
+(deftest string-test
+  (testing "pattern"
+    (let [s (m/schema [:string {:pattern "foo"}])]
+      (is (true? (m/validate s "foo")))
+      (is (true? (m/validate s "afoo")))
+      (is (true? (m/validate s "fooa")))
+      (is (false? (m/validate s "foao"))))
+    (let [s (m/schema [:string {:pattern "^foo"}])]
+      (is (true? (m/validate s "foo")))
+      (is (false? (m/validate s "afoo")))
+      (is (true? (m/validate s "fooa")))
+      (is (false? (m/validate s "foao")))))
+  (testing "charset"
+    (let [s (m/schema [:string {:charset :alphabetic}])]
+      (is (true? (m/validate s "foo")))
+      (is (false? (m/validate s "fo1o"))))
+    (let [s (m/schema [:string {:charset :letter}])]
+      (is (true? (m/validate s "foo")))
+      (is (false? (m/validate s "fo1o"))))
+    (let [s (m/schema [:string {:charset :letter-or-digit}])]
+      (is (true? (m/validate s "foo")))
+      (is (true? (m/validate s "fo0")))
+      (is (false? (m/validate s "f-1o"))))
+    (let [s (m/schema [:string {:charset #{\- :letter-or-digit}}])]
+      (is (true? (m/validate s "foo")))
+      (is (true? (m/validate s "fo0")))
+      (is (true? (m/validate s "f-1x")))
+      (is (false? (m/validate s "f?1o")))))
+  (testing "non blank"
+    (let [s (m/schema [:string {:non-blank true}])]
+      (is (true? (m/validate s "foo")))
+      (is (false? (m/validate s "")))
+      (is (false? (m/validate s "  ")))))
+  (testing "Combined"
+    (let [s (m/schema [:string {:non-blank true :pattern "foo" :charset :letter-or-digit}])]
+      (is (true? (m/validate s "foo")))
+      (is (false? (m/validate s "")))
+      (is (false? (m/validate s "  ")))
+      (is (false? (m/validate s " foo ")))
+      (is (true? (m/validate s "foo0"))))))