001 (ns dog-and-duck.quack.picky.objects
002 (:require [clojure.data.json :as json]
003 [clojure.set :refer [union]]
004 [dog-and-duck.quack.picky.constants :refer [actor-types
005 noun-types
006 re-rfc5646]]
007 [dog-and-duck.quack.picky.control-variables :refer [*reify-refs*]]
008 [dog-and-duck.quack.picky.time :refer [date-time-property-or-fault
009 xsd-date-time?
010 xsd-duration?]]
011 [dog-and-duck.quack.picky.utils :refer [concat-non-empty
012 cond-make-fault-object
013 has-activity-type?
014 has-context?
015 has-type?
016 has-type-or-fault
017 make-fault-object
018 nil-if-empty
019 object-or-uri?
020 truthy?
021 xsd-non-negative-integer?]]
022 [taoensso.timbre :refer [info warn]])
023 (:import [java.io FileNotFoundException]
024 [java.net URI URISyntaxException]))
025
026 (defn- xsd-float?
027 [pv]
028 (or (integer? pv) (float? pv)))
029
030 ;;; Copyright (C) Simon Brooke, 2022
031
032 ;;; This program is free software; you can redistribute it and/or
033 ;;; modify it under the terms of the GNU General Public License
034 ;;; as published by the Free Software Foundation; either version 2
035 ;;; of the License, or (at your option) any later version.
036
037 ;;; This program is distributed in the hope that it will be useful,
038 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
039 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
040 ;;; GNU General Public License for more details.
041
042 ;;; You should have received a copy of the GNU General Public License
043 ;;; along with this program; if not, write to the Free Software
044 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
045
046 (def object-expected-properties
047 "Requirements of properties of object, cribbed from
048 https://www.w3.org/TR/activitystreams-vocabulary/#properties
049
050 Note the following sub-key value types:
051
052 * `:collection` opposite of `:functional`: if true, value should be a
053 collection (in the Clojure sense), not a single object;
054 * `:functional` if true, value should be a single object; if false, may
055 be a single object or a sequence of objects, but each must pass
056 validation checks;
057 * `:if-invalid` a sequence of two keywords, first indicating severity,
058 second being a message key;
059 * `:if-missing` a sequence of two keywords, first indicating severity,
060 second being a message key;
061 * `:required` a boolean, or a function of one argument returning a
062 boolean, in which case the function will be applied to the object
063 having the property;
064 * `:validator` a function of one argument returning a boolean, which will
065 be applied to the value or values of the identified property."
066 {:accuracy {:functional false
067 :if-invalid [:must :invalid-number]
068 :validator (fn [pv] (and (xsd-float? pv)
069 (>= pv 0)
070 (<= pv 100)))}
071 :actor {:functional false
072 :if-invalid [:must :invalid-actor]
073 :if-missing [:must :no-actor]
074 :required has-activity-type?
075 :validator object-or-uri?}
076 :altitude {:functional false
077 :if-invalid [:must :invalid-number]
078 :validator xsd-float?}
079 :anyOf {:collection true
080 :functional false
081 ;; a Question should have a `:oneOf` or `:anyOf`, but at this layer
082 ;; that's hard to check.
083 :if-invalid [:must :invalid-option]
084 :validator object-or-uri?}
085 :attachment {:functional false
086 :if-invalid [:must :invalid-attachment]
087 :validator object-or-uri?}
088 :attributedTo {:functional false
089 :if-invalid [:must :invalid-attribution]
090 :validator object-or-uri?}
091 :audience {:functional false
092 :if-invalid [:must :invalid-audience]
093 :validator object-or-uri?}
094 :bcc {:functional false
095 :if-invalid [:must :invalid-audience] ;; do we need a separate message for bcc, cc, etc?
096 :validator object-or-uri?}
097 :cc {:functional false
098 :if-invalid [:must :invalid-audience] ;; do we need a separate message for bcc, cc, etc?
099 :validator object-or-uri?}
100 :closed {:functional false
101 :if-invalid [:must :invalid-closed]
102 :validator (fn [pv] (truthy? (or (object-or-uri? pv)
103 (xsd-date-time? pv)
104 (#{"true" "false"} pv))))}
105 :content {:functional false
106 :if-invalid [:must :invalid-content]
107 :validator string?}
108 :context {:functional false
109 :if-invalid [:must :invalid-context]
110 :validator object-or-uri?}
111 :current {:functional true
112 :if-missing [:minor :paged-collection-no-current]
113 :if-invalid [:must :paged-collection-invalid-current]
114 :required (fn [x] ;; if an object is a collection which has pages,
115 ;; it ought to have a `:current` page. But
116 ;; 1. it isn't required to, and
117 ;; 2. there's no certain way of telling that it
118 ;; does have pages - although if it has a
119 ;; `:first`, then it is.
120 (and
121 (or (has-type? x "Collection")
122 (has-type? x "OrderedCollection"))
123 (:first x)))
124 :validator (fn [pv] (object-or-uri? pv #{"CollectionPage"
125 "OrderedCollectionPage"}))}
126 :deleted {:functional true
127 :if-missing [:minor :tombstone-missing-deleted]
128 :if-invalid [:must :invalid-deleted]
129 :required (fn [x] (has-type? x "Tombstone"))
130 :validator xsd-date-time?}
131 :describes {:functional true
132 :required (fn [x] (has-type? x "Profile"))
133 :if-invalid [:must :invalid-describes]
134 ;; TODO: actually the spec says this MUST be an object and
135 ;; not a URI, which it doesn't say anywhere else, but this seems
136 ;; to make no sense?
137 :validator object-or-uri?}
138 :duration {:functional false
139 :if-invalid [:must :invalid-duration]
140 :validator xsd-duration?}
141 :endTime {:functional true
142 :if-invalid [:must :invalid-date-time]
143 :validator xsd-date-time?}
144 :first {:functional true
145 :if-missing [:minor :paged-collection-no-first]
146 :if-invalid [:must :paged-collection-invalid-first]
147 :required (fn [x] ;; if an object is a collection which has pages,
148 ;; it ought to have a `:first` page. But
149 ;; 1. it isn't required to, and
150 ;; 2. there's no certain way of telling that it
151 ;; does have pages - although if it has a
152 ;; `:last`, then it is.
153 (and
154 (or (has-type? x "Collection")
155 (has-type? x "OrderedCollection"))
156 (:last x)))
157 :validator (fn [pv] (object-or-uri? pv #{"CollectionPage"
158 "OrderedCollectionPage"}))}
159 :formerType {:functional false
160 :if-missing [:minor :tombstone-missing-former-type]
161 :if-invalid [:must :invalid-former-type]
162 :required (fn [x] (has-type? x "Tombstone"))
163 ;; The narrative of the spec says this should be an `Object`,
164 ;; but in all the provided examples it's a string.
165 :validator string?}
166 :generator {:functional false
167 :if-invalid [:must :invalid-generator]
168 :validator object-or-uri?}
169 :height {:functional false
170 :if-invalid [:must :invalid-non-negative]
171 :validator xsd-non-negative-integer?}
172 :href {:functional false
173 :if-invalid [:must :invalid-href]
174 :validator (fn [pv] (try (uri? (URI. pv))
175 (catch URISyntaxException _ false)))}
176 :hreflang {:validator (fn [pv] (truthy? (re-matches re-rfc5646 pv)))}
177 :icon {:functional false
178 :if-invalid [:must :invalid-icon]
179 ;; an icon is also expected to have a 1:1 aspect ratio, but that's
180 ;; too much detail at this level of verification
181 :validator (fn [pv] (object-or-uri? pv "Image"))}
182 :id {:functional true
183 :if-missing [:minor :no-id-transient]
184 :if-invalid [:must :invalid-id]
185 :validator (fn [pv] (try (uri? (URI. pv))
186 (catch URISyntaxException _ false)))}
187 :image {:functional false
188 :if-invalid [:must :invalid-image]
189 :validator (fn [pv] (object-or-uri? pv "Image"))}
190 :inReplyTo {:functional false
191 :if-invalid [:must :invalid-in-reply-to]
192 :validator (fn [pv] (object-or-uri? pv noun-types))}
193 :instrument {:functional false
194 :if-invalid [:must :invalid-instrument]
195 :validator object-or-uri?}
196 :items {:collection true
197 :functional false
198 :if-invalid [:must :invalid-items]
199 :if-missing [:must :no-items-or-pages]
200 :required (fn [x] (or (has-type? x "CollectionPage")
201 (and (has-type? x "Collection")
202 ;; if it's a collection and has pages,
203 ;; it doesn't need items.
204 (not (:current x))
205 (not (:first x))
206 (not (:last x)))))
207 :validator (fn [pv] (and (coll? pv) (every? object-or-uri? pv)))}
208 :last {:functional true
209 :if-missing [:minor :paged-collection-no-last]
210 :if-invalid [:must :paged-collection-invalid-last]
211 :required (fn [x] (if (and
212 (string? x)
213 (try (uri? (URI. x))
214 (catch URISyntaxException _ false)))
215 true
216 ;; if an object is a collection which has pages,
217 ;; it ought to have a `:last` page. But
218 ;; 1. it isn't required to, and
219 ;; 2. there's no certain way of telling that it
220 ;; does have pages - although if it has a
221 ;; `:first`, then it is.
222 (and
223 (has-type? x #{"Collection"
224 "OrderedCollection"})
225 (:first x))))
226 :validator (fn [pv] (object-or-uri? pv #{"CollectionPage"
227 "OrderedCollectionPage"}))}
228 :latitude {:functional true
229 :if-invalid [:must :invalid-latitude]
230 ;; The XSD spec says this is an IEEE 754-2008, and the IEEE
231 ;; wants US$104 for me to find out what that is. So I don't
232 ;; strictly know that an integer is valid here.
233 :validator xsd-float?}
234 :location {:functional false
235 :if-invalid [:must :invalid-location]
236 :validator (fn [pv] (object-or-uri? pv #{"Place"}))}
237 :longitude {:functional true
238 :if-invalid [:must :invalid-longitude]
239 :validator xsd-float?}
240 :mediaType {:functional true
241 :if-invalid [:must :invalid-mime-type]
242 :validator (fn [pv] (truthy? (re-matches #"\w+/[-.\w]+(?:\+[-.\w]+)?" pv)))}
243 :name {:functional false
244 :if-invalid [:must :invalid-name]
245 :validator string?}
246 :next {:functional true
247 :if-invalid [:must :invalid-next-page]
248 :validator (fn [pv] (object-or-uri? pv #{"CollectionPage"
249 "OrderedCollectionPage"}))}
250 :object {:functional false
251 :if-invalid [:must :invalid-direct-object]
252 :validator object-or-uri?}
253 :oneOf {:collection true
254 :functional false
255 ;; a Question should have a `:oneOf` ot `:anyOf`, but at this layer
256 ;; that's hard to check.
257 :if-invalid [:must :invalid-option]
258 :validator object-or-uri?}
259
260 :orderedItems {:collection true
261 :functional false
262 :if-invalid [:must :invalid-items]
263 :if-missing [:must :no-items-or-pages]
264 :required (fn [x] (or (has-type? x "OrderedCollectionPage")
265 (and (has-type? x "OrderedCollection")
266 ;; if it's a collection and has pages,
267 ;; it doesn't need items.
268 (not (:current x))
269 (not (:first x))
270 (not (:last x)))))
271 :validator (fn [pv] (and (coll? pv) (every? object-or-uri? pv)))}
272 :origin {:functional false
273 :if-invalid [:must :invalid-origin]
274 :validator object-or-uri?}
275 :partOf {:functional true
276 :if-missing [:must :missing-part-of]
277 :if-invalid [:must :invalid-part-of]
278 :required (fn [x] (object-or-uri? x #{"CollectionPage"
279 "OrderedCollectionPage"}))
280 :validator (fn [pv] (object-or-uri? pv #{"Collection"
281 "OrderedCollection"}))}
282 :prev {:functional true
283 :if-invalid [:must :invalid-prior-page]
284 :validator (fn [pv] (object-or-uri? pv #{"CollectionPage"
285 "OrderedCollectionPage"}))}
286 :preview {:functional false
287 :if-invalid [:must :invalid-preview]
288 ;; probably likely to be an Image or Video, but that isn't stated.
289 :validator object-or-uri?}
290 :published {:functional true
291 :if-invalid [:must :invalid-date-time]
292 :validator xsd-date-time?}
293 :replies {:functional true
294 :if-invalid [:must :invalid-replies]
295 :validator (fn [pv] (object-or-uri? pv #{"Collection"
296 "OrderedCollection"}))}
297 :radius {:functional true
298 :if-invalid [:must :invalid-positive-number]
299 :validator (fn [pv] (and (xsd-float? pv) (> pv 0)))}
300 :rel {:functional false
301 :if-invalid [:must :invalid-link-relation]
302 ;; TODO: this is not really good enough.
303 :validator (fn [pv] (truthy? (re-matches #"[a-zA-A0-9_\-\.\:\?/\\]*" pv)))}
304 :relationship {;; this exists in the spec, but it doesn't seem to be required and it's
305 ;; extremely hazily specified.
306 }
307 :result {:functional false
308 :if-invalid [:must :invalid-result]
309 :validator object-or-uri?}
310 :startIndex {:functional true
311 :if-invalid [:must :invalid-start-index]
312 :validator xsd-non-negative-integer?}
313 :start-time {:functional true
314 :if-invalid [:must :invalid-date-time]
315 :validator xsd-date-time?}
316 :subject {:functional true
317 :if-invalid [:must :invalid-subject]
318 :if-missing [:minor :no-relationship-subject]
319 :required (fn [x] (has-type? x "Relationship"))
320 :validator object-or-uri?}
321 :summary {:functional false
322 :if-invalid [:must :invalid-summary]
323 ;; TODO: HTML formatting is allowed, but other forms of formatting
324 ;; are not. Can this be validated?
325 :validator string?}
326 :tag {:functional false
327 :if-invalid [:must :invalid-tag]
328 :validator object-or-uri?}
329 :target {:functional false
330 :if-invalid [:must :invalid-target]
331 :validator object-or-uri?}
332 :to {:functional false
333 :if-invalid [:must :invalid-to]
334 :validator (fn [pv] (object-or-uri? pv actor-types))}
335 :totalItems {:functional true
336 :if-invalid [:must :invalid-total-items]
337 :validator xsd-non-negative-integer?}
338 :type {:functional false
339 :if-missing [:minor :no-type]
340 :if-invalid [:must :invalid-type]
341 ;; strictly, it's an `anyURI`, but realistically these are not checkable.
342 :validator string?}
343 :units {:functional true
344 :if-invalid [:must :invalid-units]
345 ;; the narrative says that `anyURI`, but actually unless it's a recognised
346 ;; unit the property is useless. These are the units explicitly specified.
347 :validator (fn [pv] (#{"cm" "feet" "inches" "km" "m" "miles"} pv))}
348 :updated {:functional true
349 :if-invalid [:must :invalid-updated]
350 :validator xsd-date-time?}
351 :url {:functional false
352 :if-invalid [:must :invalid-url-property]
353 :validator (fn [pv] (object-or-uri? pv "Link"))}
354 :width {:functional true
355 :if-invalid [:must :invalid-width]
356 :validator xsd-non-negative-integer?}})
357
358 (defn check-property-required [obj prop clause]
359 (let [required (:required clause)
360 [severity token] (:if-missing clause)]
361 (when required
362 (when
363 (and (apply required (list obj)) (not (obj prop)))
364 (make-fault-object severity token)))))
365
366 (defn check-property-valid
367 [obj prop clause]
368 ;; (info "obj" obj "prop" prop "clause" clause)
369 (let [val (obj prop)
370 validator (:validator clause)
371 [severity token] (:if-invalid clause)]
372 (when (and val validator)
373 (cond-make-fault-object
374 (apply validator (list val))
375 severity token))))
376
377 (defn check-property [obj prop]
378 (assert (map? obj))
379 (assert (keyword? prop))
380 (let [clause (object-expected-properties prop)]
381 (nil-if-empty
382 (remove nil?
383 (list
384 (check-property-required obj prop clause)
385 (check-property-valid obj prop clause))))))
386
387 (defn properties-faults
388 "Return a lost of faults found on properties of the object `x`, or
389 `nil` if none are."
390 [x]
391 (apply
392 concat-non-empty
393 (let [props (set (keys x))
394 required (set
395 (filter
396 #((object-expected-properties %) :required)
397 (keys object-expected-properties)))]
398 (map
399 (fn [p] (check-property x p))
400 (union props required)))))
401
402 (defn object-faults
403 "Return a list of faults found in object `x`, or `nil` if none are.
404
405 If `expected-type` is also passed, verify that `x` has `expected-type`.
406 `expected-type` may be passed as a string or as a set of strings. Detailed
407 verification of the particular features of types is not done here."
408
409 ;; TODO: many more properties which are nor required, nevertheless have required
410 ;; property TYPES as detailed in
411 ;; https://www.w3.org/TR/activitystreams-vocabulary/#properties
412 ;; if these properties are present, these types should be checked.
413 ([x]
414 (concat-non-empty
415 (remove empty?
416 (list
417 (when-not (map? x)
418 (make-fault-object :critical :not-an-object))
419 (when-not
420 (has-context? x)
421 (make-fault-object :should :no-context))
422 (when-not (:type x)
423 (make-fault-object :minor :no-type))
424 (when-not (and (map? x) (contains? x :id))
425 (make-fault-object :minor :no-id-transient))))
426 (properties-faults x)))
427 ([x expected-type]
428 (concat-non-empty
429 (object-faults x)
430 (when expected-type
431 (list
432 (has-type-or-fault x expected-type :critical :unexpected-type))))))
433
434 (def maybe-reify
435 "If `*reify-refs*` is `true`, return the object at this `target` URI.
436 Returns `nil` if
437
438 1. `*reify-refs*` is false;
439 2. the object was not found;
440 3. access to the object was not permitted.
441
442 Consequently, use with care."
443 (memoize
444 (fn [target]
445 (try (let [uri (URI. target)]
446 (when *reify-refs*
447 (json/read-str (slurp uri))))
448 (catch URISyntaxException _
449 (warn "Reification target" target "was not a valid URI.")
450 nil)
451 (catch FileNotFoundException _
452 (warn "Reification target" target "was not found.")
453 nil)))))
454
455 (defn maybe-reify-or-faults
456 "If `*reify-refs*` is `true`, runs basic checks on the object at this
457 `target` URI, if it is found, or a list containing a fault object with
458 this `severity` and `token` if it is not."
459 [value expected-type severity token]
460 (let [object (maybe-reify value)]
461 (cond object
462 (object-faults object expected-type)
463 *reify-refs* (list (make-fault-object severity token)))))
464
465 (defn object-reference-or-faults
466 "If this `value` is either
467
468 1. an object of `expected-type`;
469 2. a URI referencing an object of `expected-type`; or
470 3. a link object referencing an object of `expected-type`
471
472 and no faults are returned from validating the linked object, then return
473 `nil`; else return a sequence comprising a fault object with this `severity`
474 and `token`, prepended to the faults returned.
475
476 As with `has-type-or-fault` (q.v.), `expected-type` may be passed as a
477 string, as a set of strings, or `nil` (indicating the type of the
478 referenced object should not be checked).
479
480 **NOTE THAT** if `*reify-refs*` is `false`, referenced objects will not
481 actually be checked."
482 [value expected-type severity token]
483 (let [faults (cond
484 (string? value) (maybe-reify-or-faults value severity token expected-type)
485 (map? value) (if (has-type? value "Link")
486 (cond
487 ;; if we were looking for a link and we've
488 ;; found a link, that's OK.
489 (= expected-type "Link") nil
490 (and (set? expected-type) (expected-type "Link")) nil
491 (nil? expected-type) nil
492 :else
493 (object-reference-or-faults
494 (:href value) expected-type severity token))
495 (object-faults value expected-type))
496 :else (throw
497 (ex-info
498 "Argument `value` was not an object or a link to an object"
499 {:arguments {:value value}
500 :expected-type expected-type
501 :severity severity
502 :token token})))]
503 (when faults (cons (make-fault-object severity token) faults))))
504
505 (defn coll-object-reference-or-fault
506 "As object-reference-or-fault, except `value` argument may also be a list of
507 objects and/or object references."
508 [value expected-type severity token]
509 (cond
510 (map? value) (object-reference-or-faults value expected-type severity token)
511 (coll? value) (concat-non-empty
512 (map
513 #(object-reference-or-faults
514 % expected-type severity token)
515 value))
516 :else (throw
517 (ex-info
518 "Argument `value` was not an object, a link to an object, nor a list of these."
519 {:arguments {:value value}
520 :expected-type expected-type
521 :severity severity
522 :token token}))))