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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160 | (ns ird.gate
"Client-side domain gate: a safety net configured on
ird.client/make-gated-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. Names are compared
in DNS (punycode) form — the form the API reports — so patterns for IDNs
must be written in punycode.
Because many registration endpoints address domains by registration id,
the gate fetches the account's registrations once when attached 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.
Everything here that may need a request returns a channel; `request` is
the gated counterpart of ird.transport/request used by the mutation fns."
(:require [clojure.string :as str]
[cljs.core.async :as async]
[ird.async :as a :refer [go-try <?]]
[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
"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
"Channel of {registration-id domain-name} for every registration."
[client]
(go-try
(into {}
(keep (fn [{:keys [id domain]}]
(when (and id domain)
[(str id) (normalize domain)])))
(<? (transport/paginate client :get ["domains" "registrations"]
:registrations {:limit 100})))))
(defn attach
"Attach a domain gate to CLIENT (called by ird.client/make-gated-client).
Eagerly builds the registration id→domain cache, which requires an
authenticated client. Channel of the gated client or an error."
[client {:keys [denied-domains allowed-domains]}]
(go-try
(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). Channel of the
updated index, closed (nil) when the client has no gate."
[client]
(go-try
(when-let [gate (:gate client)]
(reset! (:registrations gate)
(<? (fetch-registration-index (dissoc client :gate)))))))
(defn- decide
"Gate decision for DOMAIN (may be nil = unresolvable): 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- resolve-registration
"Channel of the domain name for registration ID through GATE's cache,
fetching the single registration (and caching it) on a miss. Delivers nil
(closes) when the id cannot be resolved; lookup errors are swallowed —
`decide` handles unresolved ids."
[client gate id]
(let [id (str id)]
(go-try
(or (get @(:registrations gate) id)
(let [resp (async/<! (transport/request client :get ["domains" "registrations" id]))
domain (when-not (a/error? resp)
(normalize (get-in resp [:registration :domain])))]
(when domain
(swap! (:registrations gate) assoc id domain))
domain)))))
(defn check
"Decide whether the mutation OP (a string like \"POST /domains/registrations\")
may touch TARGET. Channel that closes (nil) when allowed or when the client
has no gate, or delivers an :ird/domain-denied error.
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]
(if-let [gate (:gate client)]
(go-try
(let [domain (or (:domain target)
(when-let [id (:registration-id target)]
(async/<! (resolve-registration client gate id))))]
(when-let [{:keys [domain matched-pattern]} (decide gate domain)]
(err/domain-denied domain matched-pattern op))))
(go-try nil)))
(defn request
"Gated ird.transport/request for a mutation. OP names the operation for
the error message; TARGET is a target map for `check`, or a no-arg fn
returning a channel of one — called ONLY when the client has a gate, so an
ungated client never pays for the extra read (e.g. resolving a tunnel's
hostname before deleting it). Channel of the response or an error."
([client op target method path]
(request client op target method path nil))
([client op target method path opts]
(if-not (:gate client)
(transport/request client method path opts)
(go-try
(let [target (if (fn? target) (<? (target)) target)]
(<? (check client op target))
(<? (transport/request client method path opts)))))))
|