1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140 | (ns ird.gate
"Client-side domain gate: a safety net configured on make-client via
:denied-domains / :allowed-domains that stops domain-touching MUTATIONS
(POST/PUT/PATCH/DELETE) before any request reaches the API. Reads are never
gated.
Entries are exact domain names (\"example.ro\") or wildcards
(\"*.example.ro\", matching any name under example.ro). Matching is
case-insensitive and ignores trailing dots. Deny wins over allow; when
:allowed-domains is set, anything not on it is denied.
Because many registration endpoints address domains by registration id,
the gate fetches the account's registrations once at client creation and
keeps an id→domain cache (in an atom). Ids unknown to the cache (e.g.
registered after the client was created) are resolved with a single
GET /domains/registrations/{id} and cached; ids that still cannot be
resolved pass under a pure deny-list but FAIL CLOSED under an allow-list.
`refresh!` re-fetches the whole cache."
(:require
[clojure.string :as str]
[ird.errors :as err]
[ird.transport :as transport]))
(defn normalize
"Normalize a domain name for matching: lower-case, trimmed, no trailing
dot. Returns nil for blank input."
[domain]
(when-not (str/blank? (str domain))
(-> (str domain) str/trim str/lower-case (str/replace #"\.+$" ""))))
(defn- pattern-matches?
"True when normalized NAME matches PATTERN (exact name or *.suffix
wildcard). A wildcard also matches the bare suffix itself."
[pattern name]
(let [pattern (normalize pattern)]
(cond
(nil? pattern) false
(str/starts-with? pattern "*.")
(let [suffix (subs pattern 2)]
(or (= name suffix)
(str/ends-with? name (str "." suffix))))
:else (= pattern name))))
(defn- match-pattern
"Return the first pattern in PATTERNS matching DOMAIN, else nil."
[patterns domain]
(when-let [name (normalize domain)]
(some #(when (pattern-matches? % name) %) patterns)))
(defn- fetch-registration-index
"Fetch all registrations and return {registration-id domain-name}."
[client]
(let [regs (transport/paginate client :get "/domains/registrations"
:registrations {:limit 100})]
(into {}
(keep (fn [{:keys [id domain]}]
(when (and id domain)
[(str id) (normalize domain)])))
regs)))
(defn attach
"Attach a domain gate to CLIENT (called by ird.client/make-client when
:denied-domains or :allowed-domains is set). Eagerly builds the
registration id→domain cache, which requires an authenticated client."
[client {:keys [denied-domains allowed-domains]}]
(when (str/blank? (str (:api-key client)))
(throw (err/config-error
"Domain gate options require an authenticated client (:api-key)"
{:denied-domains denied-domains :allowed-domains allowed-domains})))
;; nil and empty allow-lists differ: nil means "no allow-list", empty
;; means "allow nothing" — so preserve nil instead of coercing to [].
(assoc client :gate {:denied (some-> denied-domains vec)
:allowed (some-> allowed-domains vec)
:registrations (atom (fetch-registration-index client))}))
(defn refresh!
"Re-fetch the registration id→domain cache of CLIENT's gate (for
long-lived clients that registered domains after creation). Returns the
updated index, or nil when the client has no gate."
[client]
(when-let [gate (:gate client)]
(reset! (:registrations gate)
(fetch-registration-index (dissoc client :gate)))))
(defn- decide
"Gate decision for DOMAIN (may be nil = unresolvable): returns nil to
allow, or {:domain :matched-pattern} to deny."
[{:keys [denied allowed]} domain]
(let [name (normalize domain)]
(cond
(nil? name)
(when allowed {:domain nil :matched-pattern nil})
(match-pattern denied name)
{:domain name :matched-pattern (match-pattern denied name)}
(and allowed (not (match-pattern allowed name)))
{:domain name :matched-pattern nil}
:else nil)))
(defn- fetch-registration-domain
"Fetch a single registration's domain name by ID, returning nil when the
id is unknown or the lookup fails."
[client id]
(try
(normalize (get-in (transport/request client :get
(str "/domains/registrations/" id))
[:registration :domain]))
(catch Exception _ nil)))
(defn- resolve-registration
"Resolve a registration ID to a domain name through GATE's cache, fetching
the single registration (and caching it) on a miss. Returns nil when the
id cannot be resolved."
[client gate id]
(let [id (str id)]
(or (get @(:registrations gate) id)
(when-let [domain (fetch-registration-domain client id)]
(swap! (:registrations gate) assoc id domain)
domain))))
(defn check!
"Assert that the mutation OP (a string like \"POST /domains/registrations\")
may touch TARGET, throwing :ird/domain-denied otherwise. No-op for clients
without a gate.
TARGET is {:domain <name>} for operations that carry a literal domain
name, or {:registration-id <id>} for operations addressing a registration —
resolved through the gate's cache, with a cache miss falling back to a
single-registration fetch. Ids that still cannot be resolved pass under a
pure deny-list and fail closed under an allow-list."
[client op target]
(when-let [gate (:gate client)]
(let [domain (or (:domain target)
(when-let [id (:registration-id target)]
(resolve-registration client gate id)))]
(when-let [{:keys [domain matched-pattern]} (decide gate domain)]
(throw (err/domain-denied domain matched-pattern op)))))
nil)
|