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.objects :refer [coll-object-reference-or-fault
035 object-faults
036 object-reference-or-faults]]
037 [dog-and-duck.quack.picky.utils :refer [any-or-faults
038 concat-non-empty
039 has-activity-type?
040 has-actor-type? has-type?
041 has-type-or-fault
042 make-fault-object
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
210 (persistent-object-faults x)
211 (activity-type-faults x)
212 (list
213 (when-not
214 (has-activity-type? x)
215 (make-fault-object :must :not-activity-type))
216 (when-not (string? (:summary x)) (make-fault-object :should :no-summary)))))
217
218 (defn collection-faults
219 "Return a list of faults found in the collection `x`; if `type` is also
220 specified, it should be a string naming a specific collection type for
221 which checks should be performed.
222
223 Every collection *should*(?) have a `totalItems` field (an integer).
224
225 Beyond that, collections are either 'just collections' (in which case
226 they *should* have an `items` field (a sequence)), or else they're paged
227 collections, in which case they *must*(?) have a `first` field which is
228 a collection page or a URI pointing to a collection page, and *should*
229 have a `last` field which is similar.
230
231 The pages of collections *should* be collection pages; the pages of
232 ordered collections *should* be ordered collection pages."
233 ([x]
234 (collection-faults
235 x
236 (first
237 (remove nil?
238 (map #(when (has-type? x %) %)
239 ["Collection"
240 "OrderedCollection"
241 "CollectionPage"
242 "OrderedCollectionPage"])))))
243 ([x type]
244 ;; (log/info "collection-faults called with argumens " x ", " type)
245 (case type
246 ("Collection" "OrderedCollection") (any-or-faults
247 (list (simple-collection-faults x type)
248 (paged-collection-faults x type))
249 :must
250 :no-items)
251 ("CollectionPage" "OrderedCollectionPage") (collection-page-faults x type)
252 (list (make-fault-object :critical :expected-collection)))))