# dog_and_duck/quack/picky.clj

001 (ns dog-and-duck.quack.picky "Fault-finder for ActivityPub documents.
002
003 Generally, each `-faults` function will return:
004
005 1. `nil` if no faults were found;
006 2. a sequence of fault objects if faults were found.
007
008 Each fault object shall have the properties:
009
010 1. `:@context` whose value shall be the URL of a
011 document specifying this vocabulary;
012 2. `:type` whose value shall be `Fault`;
013 3. `:severity` whose value shall be one of
014 `info`, `minor`, `should`, `must` or `critical`;
015 4. `:fault` whose value shall be a unique token
016 representing the particular fault type;
017 5. `:narrative` whose value shall be a natural
018 language description of the fault type.
019
020 Note that the reason for the `:fault` property is
021 to be able to have a well known place, linked to
022 from the @context URL, which allows narratives
023 for each fault type to be served in as many
024 natural languages as possible.
025
026 The idea further is that it should ultimately be
027 possible to serialise a fault report as a
028 document which in its own right conforms to the
029 ActivityStreams spec."
030 (:require [dog-and-duck.quack.picky.collections :refer [collection-page-faults
031 paged-collection-faults
032 simple-collection-faults]]
033 [dog-and-duck.quack.picky.constants :refer [actor-types]]
034 [dog-and-duck.quack.picky.utils :refer [any-or-faults
035 coll-object-reference-or-fault
036 concat-non-empty
037 has-activity-type?
038 has-actor-type? has-type?
039 has-type-or-fault
040 make-fault-object
041 object-faults
042 object-reference-or-faults
043 string-or-fault]])
044 (:import [java.net URI URISyntaxException]))
045
046 ;;; Copyright (C) Simon Brooke, 2022
047
048 ;;; This program is free software; you can redistribute it and/or
049 ;;; modify it under the terms of the GNU General Public License
050 ;;; as published by the Free Software Foundation; either version 2
051 ;;; of the License, or (at your option) any later version.
052
053 ;;; This program is distributed in the hope that it will be useful,
054 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
055 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
056 ;;; GNU General Public License for more details.
057
058 ;;; You should have received a copy of the GNU General Public License
059 ;;; along with this program; if not, write to the Free Software
060 ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
061
062 (defn uri-or-fault
063 "If `u` is not a valid URI, return a fault object with this `severity` and
064 `if-invalid-token`. If it's `nil`, return a fault object with this `severity`
065 and `if-missing-token`. Otherwise return nil."
066 ([u severity if-missing-token]
067 (uri-or-fault u severity if-missing-token if-missing-token))
068 ([u severity if-missing-token if-invalid-token]
069 (try
070 (if (uri? (URI. u))
071 nil
072 (make-fault-object severity if-invalid-token))
073 (catch URISyntaxException _
074 (make-fault-object severity if-invalid-token))
075 (catch NullPointerException _
076 (make-fault-object severity if-missing-token)))))
077
078 (defn persistent-object-faults
079 "Return a list of faults found in persistent object `x`, or `nil` if none are."
080 ([x]
081 (concat-non-empty
082 (object-faults x)
083 (list
084 (if (contains? x :id)
085 (try (let [id (URI. (:id x))]
086 (when-not (= (.getScheme id) "https")
087 (make-fault-object :should :id-not-https)))
088 (catch URISyntaxException _
089 (make-fault-object :must :id-not-uri))
090 (catch NullPointerException _
091 (make-fault-object :must :null-id-persistent)))
092 (make-fault-object :must :no-id-persistent)))))
093 ([x types severity token]
094 (concat-non-empty
095 (persistent-object-faults x)
096 (list
097 (has-type-or-fault x types severity token)))))
098
099 (defn actor-faults
100 "Return a list of faults found in actor `x`, or `nil` if none are."
101 [x]
102 (concat-non-empty
103 (persistent-object-faults x)
104 (list
105 (when-not (has-actor-type? x)
106 (make-fault-object :must :not-actor-type))
107 (uri-or-fault
108 (:inbox x) :must :no-inbox :invalid-inbox-uri)
109 (uri-or-fault
110 (:outbox x) :must :no-outbox :invalid-outbox-uri))))
111
112 (defn link-faults
113 "A link object is required to have an `href` property. It may have all of
114 `rel` | `mediaType` | `name` | `hreflang` | `height` | `width` | `preview`
115 but I *think* they're all optional."
116 [x]
117 (concat-non-empty
118 (object-reference-or-faults x "Link" :critical :expected-link)
119 (list
120 (uri-or-fault
121 (:href x) :must :no-href-uri :invalid-href-uri)
122 (string-or-fault (:mediaType x) :minor :no-media-type #"\w+\/[-+.\w]+")
123 ;; TODO: possibly more here. Audit against the specs
124 )))
125
126 (def ^:const base-activity-required-properties
127 "Properties most activities should have. Values are validating functions, each.
128
129 See https://www.w3.org/TR/activitystreams-vocabulary/#dfn-activity"
130 {:summary (fn [v] (when-not (string? v)
131 (list (make-fault-object :should :no-summary))))
132 :actor (fn [v] (object-reference-or-faults v actor-types :must :no-actor))
133 :object (fn [v] (object-reference-or-faults v nil :must :no-object))})
134
135 (def ^:const intransitive-activity-required-properties
136 "Properties intransitive activities should have.
137
138 See https://www.w3.org/TR/activitystreams-vocabulary/#dfn-intransitiveactivity"
139 (dissoc base-activity-required-properties :object))
140
141 (def ^:const accept-required-properties
142 "As base-activity-required-properties, except that the type of the object
143 is restricted."
144 (assoc base-activity-required-properties
145 :object
146 (fn [v]
147 (object-reference-or-faults v #{"Invite" "Person"}
148 :must
149 :bad-accept-target))))
150
151 (def ^:const activity-required-properties
152 "Properties activities should have, keyed by activity type. Values are maps
153 of the format of `base-activity-required-properties`, q.v."
154 {"Accept" accept-required-properties
155 "Add" base-activity-required-properties
156 "Announce" base-activity-required-properties
157 "Arrive" intransitive-activity-required-properties
158 ;; TODO: is `:location` required for arrive?
159 "Block" base-activity-required-properties
160 "Create" base-activity-required-properties
161 "Delete" base-activity-required-properties
162 "Dislike" base-activity-required-properties
163 "Flag" base-activity-required-properties
164 "Follow" base-activity-required-properties
165 ;; TODO: is `:object` required to be an actor?
166 "Ignore" base-activity-required-properties
167 "Invite" (assoc base-activity-required-properties :target
168 (fn [v]
169 (coll-object-reference-or-fault v #{"Event" "Group"}
170 :must
171 :bad-accept-target)))
172 ;; TODO: are here other things one could meaningfully be invited to?
173 "Join" base-activity-required-properties
174 "Leave" base-activity-required-properties
175 "Like" base-activity-required-properties
176 "Listen" base-activity-required-properties
177 "Move" base-activity-required-properties
178 "Offer" base-activity-required-properties
179 "Question" intransitive-activity-required-properties
180 "Reject" base-activity-required-properties
181 "Read" base-activity-required-properties
182 "Remove" base-activity-required-properties
183 "TentativeReject" base-activity-required-properties
184 "TentativeAccept" accept-required-properties
185 "Travel" base-activity-required-properties
186 "Undo" base-activity-required-properties
187 "Update" base-activity-required-properties
188 "View" base-activity-required-properties})
189
190 (defn activity-type-faults
191 "Return a list of faults found in the activity `x`; if `type` is also
192 specified, it should be a string naming a specific activity type for
193 which checks should be performed.
194
195 Some specific activity types have specific requirements which are not
196 requirements."
197 ([x]
198 (if (coll? (:type x))
199 (map #(activity-type-faults x %) (:type x))
200 (activity-type-faults x (:type x))))
201 ([x type]
202 (let [checks (activity-required-properties type)]
203 (map
204 #(apply (checks %) (x %))
205 (keys checks)))))
206
207 (defn activity-faults
208 [x]
209 (concat-non-empty (persistent-object-faults x)
210 (activity-type-faults x)
211 (list
212 (when-not
213 (has-activity-type? x)
214 (make-fault-object :must :not-activity-type))
215 (when-not (string? (:summary x)) (make-fault-object :should :no-summary)))))
216
217 (defn collection-faults
218 "Return a list of faults found in the collection `x`; if `type` is also
219 specified, it should be a string naming a specific collection type for
220 which checks should be performed.
221
222 Every collection *should*(?) have a `totalItems` field (an integer).
223
224 Beyond that, collections are either 'just collections' (in which case
225 they *should* have an `items` field (a sequence)), or else they're paged
226 collections, in which case they *must*(?) have a `first` field which is
227 a collection page or a URI pointing to a collection page, and *should*
228 have a `last` field which is similar.
229
230 The pages of collections *should* be collection pages; the pages of
231 ordered collections *should* be ordered collection pages."
232 ([x]
233 (collection-faults
234 x
235 (first
236 (remove nil?
237 (map #(when (has-type? x %) %)
238 ["Collection"
239 "OrderedCollection"
240 "CollectionPage"
241 "OrderedCollectionPage"])))))
242 ([x type]
243 ;; (log/info "collection-faults called with argumens " x ", " type)
244 (case type
245 ("Collection" "OrderedCollection") (any-or-faults
246 (list (simple-collection-faults x type)
247 (paged-collection-faults x type))
248 :must
249 :no-items)
250 ("CollectionPage" "OrderedCollectionPage") (collection-page-faults x type)
251 (list (make-fault-object :critical :expected-collection)))))