Skip to content

Commit ae8b02c

Browse files
XOMAv2XOMAv2
committed
Lesson 22 has been added
1 parent 907f144 commit ae8b02c

File tree

3 files changed

+324
-0
lines changed

3 files changed

+324
-0
lines changed

‎otus-22/project.clj

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
(defproject otus-22 "0.1.0-SNAPSHOT"
2+
:description "FIXME: write description"
3+
:url "http://example.com/FIXME"
4+
:license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0"
5+
:url "https://www.eclipse.org/legal/epl-2.0/"}
6+
:dependencies [[camel-snake-kebab "0.4.3"]
7+
[metosin/malli "0.11.0"]
8+
[org.clojure/clojure "1.11.1"]]
9+
:main ^:skip-aot otus-22.core
10+
:target-path "target/%s"
11+
:profiles {:uberjar {:aot :all
12+
:jvm-opts ["-Dclojure.compiler.direct-linking=true"]}})

‎otus-22/src/otus_22/core.clj

Lines changed: 146 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
1+
(ns otus-22.core
2+
(:require [malli.core :as m]
3+
[malli.swagger :as swagger]
4+
[malli.transform :as mt]
5+
[malli.dot :as dot]
6+
[camel-snake-kebab.core :as csk]
7+
[malli.util :as mu])
8+
(:gen-class))
9+
10+
;; type
11+
;; [type & children]
12+
;; [type properties & children]
13+
14+
(m/validate :int 13)
15+
(m/validate :string "13")
16+
17+
(m/validate [:vector int?] [13])
18+
(m/validate [:set int?] [13])
19+
20+
(m/validate int? 13)
21+
(m/validate string? 13)
22+
23+
(m/validate [:string {:min 3}] "13")
24+
(m/validate [:string {:min 3}] "133")
25+
(m/validate [string? {:min 3}] "13")
26+
27+
28+
(def account-schema
29+
[:map
30+
[:id integer?]
31+
[:username string?]
32+
[:password string?]
33+
[:email string?]
34+
[:created-on inst?]])
35+
36+
37+
(m/validate account-schema
38+
{:id 1
39+
:username "username"
40+
:password "password"
41+
:email "email"
42+
:created-on #inst "2020"})
43+
44+
(m/validate account-schema
45+
{:id 12})
46+
47+
(m/decode inst?
48+
"2020-01-01T00:00:00.000-00:00"
49+
mt/json-transformer)
50+
51+
(m/encode inst?
52+
#inst "2020-01-01T00:00:00.000-00:00"
53+
mt/json-transformer)
54+
55+
(def strict-transformer
56+
(mt/transformer (mt/key-transformer {:encode csk/->camelCaseString
57+
:decode csk/->kebab-case-keyword})
58+
mt/strip-extra-keys-transformer
59+
mt/json-transformer))
60+
61+
(m/decode account-schema
62+
{"id" 1
63+
"username" "username"
64+
"password" "password"
65+
"email" "email"
66+
"createdOn" "2020-01-01T00:00:00.000-00:00"
67+
"extraKey1" 1
68+
"extraKey2" 2}
69+
strict-transformer)
70+
71+
;; "{\"key\": \"value\"}" => {"key" "value"}
72+
73+
(-> [:map
74+
[:x int?]
75+
[:y int?]]
76+
(update 1 (fn [[k v]]
77+
[k {:optional true} v]))
78+
(update 2 (fn [[k v]]
79+
[k {:optional true} v])))
80+
81+
(mu/optional-keys [:map
82+
[:x int?]
83+
[:y int?]])
84+
85+
(m/parse
86+
[:* [:catn
87+
[:prop string?]
88+
[:val [:altn
89+
[:s string?]
90+
[:b boolean?]]]]]
91+
["-server" "foo" "-verbose" true "-user" "joe"])
92+
93+
(def InnerAddress
94+
[:map
95+
[:street string?]
96+
[:city string?]
97+
[:zip int?]
98+
[:lonlat [:tuple double? double?]]])
99+
100+
(def Address
101+
[:map
102+
[:id string?]
103+
[:tags [:set keyword?]]
104+
[:address InnerAddress]])
105+
106+
(swagger/transform Address)
107+
108+
(let [dot-graph (dot/transform Address)]
109+
(spit "graph.dot" dot-graph)
110+
(println dot-graph))
111+
112+
(def Order
113+
[:schema
114+
{:registry {"Country" [:map
115+
[:name [:enum :FI :PO]]
116+
[:neighbors [:vector [:ref "Country"]]]]
117+
"Burger" [:map
118+
[:name string?]
119+
[:description {:optional true} string?]
120+
[:origin [:maybe "Country"]]
121+
[:price pos-int?]]
122+
"OrderLine" [:map
123+
[:burger "Burger"]
124+
[:amount int?]]
125+
"Order" [:map
126+
[:lines [:vector "OrderLine"]]
127+
[:delivery [:map
128+
[:delivered boolean?]
129+
[:address [:map
130+
[:street string?]
131+
[:zip int?]
132+
[:country "Country"]]]]]]}}
133+
"Order"])
134+
135+
(let [dot-graph (dot/transform Order)]
136+
(spit "graph.dot" dot-graph)
137+
(println dot-graph))
138+
139+
(m/walk Address
140+
(m/schema-walker
141+
#(mu/update-properties % assoc :title (name (m/type %)))))
142+
143+
(defn -main
144+
"I don't do a whole lot ... yet."
145+
[& args]
146+
(println "Hello, World!"))

‎otus-22/src/otus_22/malli/ddl.clj

Lines changed: 166 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,166 @@
1+
(ns otus-22.malli.ddl
2+
(:require [camel-snake-kebab.core :as csk]
3+
[clojure.string :as string]
4+
[malli.core :as m]))
5+
6+
(set! *warn-on-reflection* true)
7+
8+
(defn- non-nilable-spec
9+
[type]
10+
{:type type
11+
:nilable? false
12+
:primary-key? false
13+
:unique? false
14+
:generated nil})
15+
16+
(defn- update-spec
17+
[spec schema]
18+
(let [{::keys [primary-key?
19+
unique?
20+
generated]} (m/properties schema)]
21+
(cond-> spec
22+
primary-key? (assoc :primary-key? true)
23+
unique? (assoc :unique? true)
24+
(= generated :always) (assoc :generated :always)
25+
(= generated :by-defalt) (assoc :generated :by-defalt))))
26+
27+
(def ^:private unknown-spec
28+
nil)
29+
30+
(defn- spec->string
31+
[key spec]
32+
(let [{:keys [type
33+
nilable?
34+
primary-key?
35+
unique?
36+
generated]} spec]
37+
(cond-> (str " \"" (-> key name csk/->snake_case_string) "\" " type)
38+
(= generated :by-defalt)
39+
(str " generated by default as identity")
40+
41+
(= generated :always)
42+
(str " generated always as identity")
43+
44+
primary-key?
45+
(str " primary key")
46+
47+
(and (not primary-key?)
48+
unique?)
49+
(str " unique")
50+
51+
(and (not primary-key?)
52+
(not nilable?))
53+
(str " not null"))))
54+
55+
(defprotocol DdlSchema
56+
"Protocol for transformer extension to new types of schemas."
57+
(-accept [this children options]
58+
"Transforms schema to DDL schema."))
59+
60+
(defmulti accept
61+
"Multimethod for transformation of schemas.
62+
Dispatching is carried out according to the schema type.
63+
* `type` - schema type;
64+
* `schema` - the original schema;
65+
* `children` - collection of transformed children;
66+
* `options` - map with additional options."
67+
(fn [type _schema _children _options]
68+
type)
69+
:default ::default)
70+
71+
(defmethod accept ::default [_ _ _ _] unknown-spec)
72+
73+
;; predicate-schemas
74+
(defmethod accept 'integer? [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
75+
(defmethod accept 'int? [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
76+
(defmethod accept 'pos-int? [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
77+
(defmethod accept 'neg-int? [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
78+
(defmethod accept 'nat-int? [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
79+
(defmethod accept 'float? [_ schema _ _] (-> (non-nilable-spec "double precision") (update-spec schema)))
80+
(defmethod accept 'double? [_ schema _ _] (-> (non-nilable-spec "double precision") (update-spec schema)))
81+
(defmethod accept 'boolean? [_ schema _ _] (-> (non-nilable-spec "boolean") (update-spec schema)))
82+
(defmethod accept 'string? [_ schema _ _] (-> (non-nilable-spec "text") (update-spec schema)))
83+
(defmethod accept 'uuid? [_ schema _ _] (-> (non-nilable-spec "uuid") (update-spec schema)))
84+
(defmethod accept 'inst? [_ schema _ _] (-> (non-nilable-spec "timestamp") (update-spec schema)))
85+
(defmethod accept 'char? [_ schema _ _] (-> (non-nilable-spec "char(1)") (update-spec schema)))
86+
(defmethod accept 'false? [_ schema _ _] (-> (non-nilable-spec "boolean") (update-spec schema)))
87+
(defmethod accept 'true? [_ schema _ _] (-> (non-nilable-spec "boolean") (update-spec schema)))
88+
89+
;; type-schemas
90+
(defmethod accept :string [_ schema _ _] (-> (non-nilable-spec "text") (update-spec schema)))
91+
(defmethod accept :int [_ schema _ _] (-> (non-nilable-spec "integer") (update-spec schema)))
92+
(defmethod accept :double [_ schema _ _] (-> (non-nilable-spec "double precision") (update-spec schema)))
93+
(defmethod accept :boolean [_ schema _ _] (-> (non-nilable-spec "boolean") (update-spec schema)))
94+
(defmethod accept :uuid [_ schema _ _] (-> (non-nilable-spec "uuid") (update-spec schema)))
95+
96+
;; base-schemas
97+
(defmethod accept :maybe [_ _ children _]
98+
(if (and (= 1 (count children))
99+
(map? (first children)))
100+
(assoc (first children) :nilable? true)
101+
unknown-spec))
102+
103+
(defmethod accept ::m/val [_ schema children _]
104+
(-> (first children)
105+
(update-spec schema)))
106+
107+
(defmethod accept :map [_ schema children _]
108+
(let [unknown-result? (fn [[_k _p v]]
109+
(nil? v))
110+
drop-properties (fn [[k _p v]]
111+
[k v])
112+
convert-to-string (fn [[k v]]
113+
(spec->string k v))
114+
processed-children (sequence (comp (remove unknown-result?)
115+
(map drop-properties)
116+
(map convert-to-string))
117+
children)
118+
{::keys [table]} (m/properties schema)
119+
120+
_ (assert (some? table) "The table schema must contain the ::table property.")
121+
_ (assert (or (string? table)
122+
(simple-keyword? table))
123+
"The ::table property should be a simple keyword or string.")
124+
125+
result (format "create table \"%s\" (\n%s\n);"
126+
(name table)
127+
(string/join ",\n" processed-children))]
128+
result))
129+
130+
(defn- sql-walker
131+
"A walker function that calls the accept fn for schema transofrmation."
132+
[schema _path children options]
133+
(if (satisfies? DdlSchema schema)
134+
(-accept schema children options)
135+
(accept (m/type schema) schema children options)))
136+
137+
(comment
138+
(defn- skip-walk
139+
([?schema f]
140+
(skip-walk ?schema f nil))
141+
([?schema f options]
142+
(let [schema (m/schema ?schema options)
143+
walker (reify m/Walker
144+
(m/-accept [_ s _ _]
145+
(when-not (::skip? (m/properties s))
146+
s))
147+
148+
(m/-inner [this s p options]
149+
(m/-walk s this p options))
150+
151+
(m/-outer [_ s p c options]
152+
(f s p c options)))]
153+
(m/-walk schema walker [] options)))))
154+
155+
(defn transform
156+
([?schema]
157+
(transform ?schema nil))
158+
([?schema options]
159+
(m/walk ?schema sql-walker (merge options {::m/walk-entry-vals true}))))
160+
161+
(println (transform [:map {::table :account}
162+
[:id {::generated :always ::primary-key? true} integer?]
163+
[:username {::unique? true} string?]
164+
[:password string?]
165+
[:email {::unique? true} string?]
166+
[:created-on inst?]]))

0 commit comments

Comments
 (0)