| 1 | ;;+----------------------------------------------------------------------------- |
|---|
| 2 | ;;+ Isidorus |
|---|
| 3 | ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff |
|---|
| 4 | ;;+ |
|---|
| 5 | ;;+ Isidorus is freely distributable under the LLGPL license. |
|---|
| 6 | ;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and |
|---|
| 7 | ;;+ trunk/docs/LGPL-LICENSE.txt. |
|---|
| 8 | ;;+----------------------------------------------------------------------------- |
|---|
| 9 | |
|---|
| 10 | (defpackage :json-delete-interface |
|---|
| 11 | (:use :cl :datamodel :json-importer) |
|---|
| 12 | (:export :mark-as-deleted-from-json)) |
|---|
| 13 | |
|---|
| 14 | (in-package :json-delete-interface) |
|---|
| 15 | |
|---|
| 16 | |
|---|
| 17 | (defun mark-as-deleted-from-json (json-data &key (revision *TM-REVISION*)) |
|---|
| 18 | "Marks an object that is specified by the given JSON data as deleted." |
|---|
| 19 | (declare (string json-data) (integer revision)) |
|---|
| 20 | (let ((json-list (json:decode-json-from-string json-data))) |
|---|
| 21 | (let ((type nil) |
|---|
| 22 | (parent nil) |
|---|
| 23 | (parent-of-parent nil) |
|---|
| 24 | (delete nil)) |
|---|
| 25 | (loop for json-entry in json-list |
|---|
| 26 | do (let ((st (car json-entry)) |
|---|
| 27 | (nd (cdr json-entry))) |
|---|
| 28 | (cond ((eql st :type) |
|---|
| 29 | (setf type nd)) |
|---|
| 30 | ((eql st :delete) |
|---|
| 31 | (setf delete nd)) |
|---|
| 32 | ((eql st :parent) |
|---|
| 33 | (setf parent nd)) |
|---|
| 34 | ((eql st :parent-of-parent) |
|---|
| 35 | (setf parent-of-parent nd))))) |
|---|
| 36 | (cond ((string= type "Topic") |
|---|
| 37 | (delete-topic-from-json delete :revision revision)) |
|---|
| 38 | ((string= type "PSI") |
|---|
| 39 | (delete-identifier-from-json delete 'd:PersistentIdC |
|---|
| 40 | #'d:delete-psi :revision revision)) |
|---|
| 41 | ((string= type "ItemIdentity") |
|---|
| 42 | (delete-identifier-from-json delete 'd:ItemIdentifierC |
|---|
| 43 | #'d:delete-item-identifier |
|---|
| 44 | :revision revision)) |
|---|
| 45 | ((string= type "SubjectLocator") |
|---|
| 46 | (delete-identifier-from-json delete 'd:SubjectLocatorC |
|---|
| 47 | #'d:delete-locator :revision revision)) |
|---|
| 48 | ((string= type "Name") |
|---|
| 49 | (delete-name-from-json |
|---|
| 50 | delete (find-parent parent :revision revision) :revision revision)) |
|---|
| 51 | ((string= type "Variant") |
|---|
| 52 | (let ((parent-top (find-parent parent-of-parent :revision revision))) |
|---|
| 53 | (delete-variant-from-json |
|---|
| 54 | delete (find-parent parent :parent-of-parent parent-top |
|---|
| 55 | :revision revision) :revision revision))) |
|---|
| 56 | ((string= type "Occurrence") |
|---|
| 57 | (delete-occurrence-from-json |
|---|
| 58 | delete (find-parent parent :revision revision) :revision revision)) |
|---|
| 59 | ((string= type "Association") |
|---|
| 60 | (delete-association-from-json delete :revision revision)) |
|---|
| 61 | ((string= type "Role") |
|---|
| 62 | (delete-role-from-json delete (find-parent parent :revision revision))) |
|---|
| 63 | (t |
|---|
| 64 | (error "Type \"~a\" is not defined" type)))))) |
|---|
| 65 | |
|---|
| 66 | |
|---|
| 67 | (defun delete-role-from-json (json-decoded-list parent-assoc |
|---|
| 68 | &key (revision *TM-REVISION*)) |
|---|
| 69 | "Deletes the passed role object and returns t otherwise this |
|---|
| 70 | function returns nil." |
|---|
| 71 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 72 | (let ((j-role (make-role-plist json-decoded-list))) |
|---|
| 73 | (when parent-assoc |
|---|
| 74 | (let ((role-to-delete |
|---|
| 75 | (loop for role in (d:roles parent-assoc :revision revision) |
|---|
| 76 | when (and |
|---|
| 77 | (eql |
|---|
| 78 | (d:instance-of role :revision revision) |
|---|
| 79 | (getf j-role :type)) |
|---|
| 80 | (eql |
|---|
| 81 | (d:player role :revision revision) |
|---|
| 82 | (getf j-role :topicRef))) |
|---|
| 83 | return role))) |
|---|
| 84 | (when role-to-delete |
|---|
| 85 | (d:delete-role parent-assoc role-to-delete :revision revision) |
|---|
| 86 | role-to-delete))))) |
|---|
| 87 | |
|---|
| 88 | |
|---|
| 89 | (defun delete-association-from-json (json-decoded-list &key |
|---|
| 90 | (revision *TM-REVISION*)) |
|---|
| 91 | "Deletes the passed association object and returns t otherwise this |
|---|
| 92 | function returns nil." |
|---|
| 93 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 94 | (let ((assoc (find-association json-decoded-list :revision revision))) |
|---|
| 95 | (when assoc |
|---|
| 96 | (d:mark-as-deleted assoc :revision revision :source-locator nil) |
|---|
| 97 | assoc))) |
|---|
| 98 | |
|---|
| 99 | |
|---|
| 100 | (defun make-role-plist (json-decoded-list &key (revision *TM-REVISION*)) |
|---|
| 101 | "Returns a plist that represents a list of association roles |
|---|
| 102 | of the passed json-decoded-list." |
|---|
| 103 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 104 | (let ((type nil) |
|---|
| 105 | (player nil)) |
|---|
| 106 | (loop for j-entry in json-decoded-list |
|---|
| 107 | do (let ((st (car j-entry)) |
|---|
| 108 | (nd (cdr j-entry))) |
|---|
| 109 | (cond ((eql st :topic-Ref) |
|---|
| 110 | (setf player |
|---|
| 111 | (json-importer::psis-to-topic nd :revision revision))) |
|---|
| 112 | ((eql st :type) |
|---|
| 113 | (setf type |
|---|
| 114 | (json-importer::psis-to-topic nd :revision revision)))))) |
|---|
| 115 | (list :type type :topicRef player))) |
|---|
| 116 | |
|---|
| 117 | |
|---|
| 118 | (defun find-association (json-decoded-list &key (revision *TM-REVISION*)) |
|---|
| 119 | "Returns an association object." |
|---|
| 120 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 121 | (let ((j-roles nil) |
|---|
| 122 | (type nil) |
|---|
| 123 | (scopes nil)) |
|---|
| 124 | (loop for j-entry in json-decoded-list |
|---|
| 125 | do (let ((st (car j-entry)) |
|---|
| 126 | (nd (cdr j-entry))) |
|---|
| 127 | (cond ((eql st :roles) |
|---|
| 128 | (setf j-roles |
|---|
| 129 | (map 'list #'(lambda(j-role) |
|---|
| 130 | (make-role-plist j-role :revision revision)) |
|---|
| 131 | nd))) |
|---|
| 132 | ((eql st :type) |
|---|
| 133 | (setf type (json-importer::psis-to-topic nd :revision revision))) |
|---|
| 134 | ((eql st :scopes) |
|---|
| 135 | (setf scopes (json-importer::json-to-scope nd revision)))))) |
|---|
| 136 | (loop for assoc in (d:get-all-associations revision) |
|---|
| 137 | when (and |
|---|
| 138 | (not |
|---|
| 139 | (set-exclusive-or |
|---|
| 140 | (d:roles assoc :revision revision) |
|---|
| 141 | j-roles |
|---|
| 142 | :test #'(lambda(a-role j-role) |
|---|
| 143 | (and (eql (d:instance-of a-role :revision revision) |
|---|
| 144 | (getf j-role :type)) |
|---|
| 145 | (eql (d:player a-role :revision revision) |
|---|
| 146 | (getf j-role :topicRef)))))) |
|---|
| 147 | (eql type (d:instance-of assoc :revision revision)) |
|---|
| 148 | (not (set-exclusive-or scopes (d:themes assoc :revision revision)))) |
|---|
| 149 | return assoc))) |
|---|
| 150 | |
|---|
| 151 | |
|---|
| 152 | (defun find-parent (parent &key (parent-of-parent nil) |
|---|
| 153 | (revision *TM-REVISION*)) |
|---|
| 154 | "Returns the construct (Topic|Name|Association) corresponding to the |
|---|
| 155 | passed parameters." |
|---|
| 156 | (declare (list parent) (integer revision) |
|---|
| 157 | (type (or TopicC null) parent-of-parent)) |
|---|
| 158 | (let ((value nil) |
|---|
| 159 | (scopes nil) |
|---|
| 160 | (type nil) |
|---|
| 161 | (j-roles nil)) |
|---|
| 162 | (loop for j-entry in parent |
|---|
| 163 | do (let ((st (car j-entry)) |
|---|
| 164 | (nd (cdr j-entry))) |
|---|
| 165 | (cond ((eql st :value) |
|---|
| 166 | (setf value nd)) |
|---|
| 167 | ((eql st :scopes) |
|---|
| 168 | (setf scopes (json-importer::json-to-scope nd revision))) |
|---|
| 169 | ((eql st :type) |
|---|
| 170 | (setf type (json-importer::psis-to-topic nd :revision revision))) |
|---|
| 171 | ((eql st :roles) |
|---|
| 172 | (setf j-roles nd))))) |
|---|
| 173 | (cond (parent-of-parent |
|---|
| 174 | (loop for name in (d:names parent-of-parent :revision revision) |
|---|
| 175 | when (and (string= value (d:charvalue name)) |
|---|
| 176 | (eql type (d:instance-of name :revision revision)) |
|---|
| 177 | (not (set-exclusive-or scopes |
|---|
| 178 | (d:themes name :revision revision)))) |
|---|
| 179 | return name)) |
|---|
| 180 | (j-roles ;must be an association |
|---|
| 181 | (find-association parent :revision revision)) |
|---|
| 182 | (t ;must be a topic |
|---|
| 183 | (find-topic-from-json-identifiers |
|---|
| 184 | parent :revision revision))))) |
|---|
| 185 | |
|---|
| 186 | |
|---|
| 187 | (defun delete-variant-from-json (json-decoded-list parent-name |
|---|
| 188 | &key (revision *TM-REVISION*)) |
|---|
| 189 | "Deletes the passed variant from the given name and returns t if the |
|---|
| 190 | operation succeeded." |
|---|
| 191 | (declare (list json-decoded-list) (integer revision) |
|---|
| 192 | (type (or NameC null))) |
|---|
| 193 | (when parent-name |
|---|
| 194 | (let ((varvalue nil) |
|---|
| 195 | (vardatatype constants::*xml-uri*) |
|---|
| 196 | (scopes nil)) |
|---|
| 197 | (loop for j-entry in json-decoded-list |
|---|
| 198 | do (let ((st (car j-entry)) |
|---|
| 199 | (nd (cdr j-entry))) |
|---|
| 200 | (cond ((eql st :resource-ref) |
|---|
| 201 | (setf varvalue nd)) |
|---|
| 202 | ((eql st :resource-data) |
|---|
| 203 | (loop for j-dt in nd |
|---|
| 204 | do (let ((dt-st (car j-dt)) |
|---|
| 205 | (dt-nd (cdr j-dt))) |
|---|
| 206 | (cond ((eql dt-st :datatype) |
|---|
| 207 | (setf vardatatype dt-nd)) |
|---|
| 208 | ((eql dt-st :value) |
|---|
| 209 | (setf varvalue dt-nd)))))) |
|---|
| 210 | ((eql st :scopes) |
|---|
| 211 | (setf scopes (json-importer::json-to-scope nd revision)))))) |
|---|
| 212 | (let ((var-to-delete |
|---|
| 213 | (loop for var in (d:variants parent-name :revision revision) |
|---|
| 214 | when (and (string= varvalue (d:charvalue var)) |
|---|
| 215 | (string= vardatatype (d:datatype var)) |
|---|
| 216 | (not (set-exclusive-or |
|---|
| 217 | scopes (d:themes var :revision revision)))) |
|---|
| 218 | return var))) (when var-to-delete |
|---|
| 219 | (delete-variant parent-name var-to-delete :revision revision) |
|---|
| 220 | var-to-delete))))) |
|---|
| 221 | |
|---|
| 222 | |
|---|
| 223 | (defun delete-occurrence-from-json (json-decoded-list parent-top |
|---|
| 224 | &key (revision *TM-REVISION*)) |
|---|
| 225 | "Deletes the passed occurrence from the given topic and returns t if the |
|---|
| 226 | operation succeeded." |
|---|
| 227 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 228 | (when parent-top |
|---|
| 229 | (let ((occvalue nil) |
|---|
| 230 | (occdatatype constants::*xml-uri*) |
|---|
| 231 | (scopes nil) |
|---|
| 232 | (type nil)) |
|---|
| 233 | (loop for j-entry in json-decoded-list |
|---|
| 234 | do (let ((st (car j-entry)) |
|---|
| 235 | (nd (cdr j-entry))) |
|---|
| 236 | (cond ((eql st :resource-ref) |
|---|
| 237 | (setf occvalue nd)) |
|---|
| 238 | ((eql st :resource-data) |
|---|
| 239 | (loop for j-dt in nd |
|---|
| 240 | do (let ((dt-st (car j-dt)) |
|---|
| 241 | (dt-nd (cdr j-dt))) |
|---|
| 242 | (cond ((eql dt-st :datatype) |
|---|
| 243 | (setf occdatatype dt-nd)) |
|---|
| 244 | ((eql dt-st :value) |
|---|
| 245 | (setf occvalue dt-nd)))))) |
|---|
| 246 | ((eql st :scopes) |
|---|
| 247 | (setf scopes (json-importer::json-to-scope nd revision))) |
|---|
| 248 | ((eql st :type) |
|---|
| 249 | (setf type (json-importer::psis-to-topic |
|---|
| 250 | nd :revision revision)))))) |
|---|
| 251 | (let ((occ-to-delete |
|---|
| 252 | (loop for occ in (d:occurrences parent-top :revision revision) |
|---|
| 253 | when (and (string= occvalue (d:charvalue occ)) |
|---|
| 254 | (string= occdatatype (d:datatype occ)) |
|---|
| 255 | (eql type (d:instance-of occ :revision revision)) |
|---|
| 256 | (not (set-exclusive-or |
|---|
| 257 | scopes (d:themes occ :revision revision)))) |
|---|
| 258 | return occ))) |
|---|
| 259 | (when occ-to-delete |
|---|
| 260 | (delete-occurrence parent-top occ-to-delete :revision revision) |
|---|
| 261 | occ-to-delete))))) |
|---|
| 262 | |
|---|
| 263 | |
|---|
| 264 | (defun delete-name-from-json (json-decoded-list parent-top |
|---|
| 265 | &key (revision *TM-REVISION*)) |
|---|
| 266 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 267 | (when parent-top |
|---|
| 268 | (let ((namevalue nil) |
|---|
| 269 | (scopes nil) |
|---|
| 270 | (type nil)) |
|---|
| 271 | (loop for j-entry in json-decoded-list |
|---|
| 272 | do (let ((st (car j-entry)) |
|---|
| 273 | (nd (cdr j-entry))) |
|---|
| 274 | (cond ((eql st :value) |
|---|
| 275 | (setf namevalue nd)) |
|---|
| 276 | ((eql st :scopes) |
|---|
| 277 | (setf scopes (json-importer::json-to-scope nd revision))) |
|---|
| 278 | ((eql st :type) |
|---|
| 279 | (setf type (json-importer::psis-to-topic |
|---|
| 280 | nd :revision revision)))))) |
|---|
| 281 | (let ((name-to-delete |
|---|
| 282 | (loop for name in (names parent-top :revision revision) |
|---|
| 283 | when (and (string= namevalue (d:charvalue name)) |
|---|
| 284 | (eql type (d:instance-of name :revision revision)) |
|---|
| 285 | (not (set-exclusive-or |
|---|
| 286 | scopes (d:themes name :revision revision)))) |
|---|
| 287 | return name))) |
|---|
| 288 | (when name-to-delete |
|---|
| 289 | (delete-name parent-top name-to-delete :revision revision) |
|---|
| 290 | name-to-delete))))) |
|---|
| 291 | |
|---|
| 292 | |
|---|
| 293 | (defun delete-identifier-from-json (uri class delete-function |
|---|
| 294 | &key (revision *TM-REVISION*)) |
|---|
| 295 | "Deleted the passed identifier of the construct it is associated with. |
|---|
| 296 | Returns t if there was deleted an item otherweise it returns nil." |
|---|
| 297 | (declare (string uri) (integer revision) (symbol class)) |
|---|
| 298 | (let ((id (elephant:get-instance-by-value |
|---|
| 299 | class 'd:uri uri))) |
|---|
| 300 | (if (and id (typep id class)) |
|---|
| 301 | (progn |
|---|
| 302 | (apply delete-function |
|---|
| 303 | (list (d:identified-construct id :revision revision) |
|---|
| 304 | id :revision revision)) |
|---|
| 305 | id) |
|---|
| 306 | nil))) |
|---|
| 307 | |
|---|
| 308 | |
|---|
| 309 | (defun delete-topic-from-json (json-decoded-list &key (revision *TM-REVISION*)) |
|---|
| 310 | "Searches for a topic corresponding to the given identifiers. |
|---|
| 311 | Returns t if there was deleted an item otherweise it returns nil." |
|---|
| 312 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 313 | (let ((top-to-delete (find-topic-from-json-identifiers |
|---|
| 314 | json-decoded-list :revision revision))) |
|---|
| 315 | (when top-to-delete |
|---|
| 316 | (mark-as-deleted top-to-delete :source-locator nil :revision revision) |
|---|
| 317 | top-to-delete))) |
|---|
| 318 | |
|---|
| 319 | |
|---|
| 320 | (defun get-ids-from-json (json-decoded-list) |
|---|
| 321 | "Returns all id uri formatted as plist generated from the json-list." |
|---|
| 322 | (let ((iis nil) |
|---|
| 323 | (psis nil) |
|---|
| 324 | (sls nil)) |
|---|
| 325 | (loop for json-entry in json-decoded-list |
|---|
| 326 | do (let ((st (car json-entry)) |
|---|
| 327 | (nd (cdr json-entry))) |
|---|
| 328 | (cond ((eql st :item-identities) |
|---|
| 329 | (setf iis nd)) |
|---|
| 330 | ((eql st :subject-locators) |
|---|
| 331 | (setf sls nd)) |
|---|
| 332 | ((eql st :subject-identifiers) |
|---|
| 333 | (setf psis nd))))) |
|---|
| 334 | (list :subjectIdentifiers psis |
|---|
| 335 | :itemIdentities iis |
|---|
| 336 | :subjectLocators sls))) |
|---|
| 337 | |
|---|
| 338 | |
|---|
| 339 | (defun find-topic-from-json-identifiers (json-decoded-list |
|---|
| 340 | &key (revision *TM-REVISION*)) |
|---|
| 341 | "Returns a topic corresponding to the passed identifiers." |
|---|
| 342 | (declare (list json-decoded-list) (integer revision)) |
|---|
| 343 | (let ((ids (get-ids-from-json json-decoded-list))) |
|---|
| 344 | (let ((identifier |
|---|
| 345 | (if (getf ids :itemIdentities) |
|---|
| 346 | (elephant:get-instance-by-value |
|---|
| 347 | 'd:ItemIdentifierC 'd:uri (first (getf ids :itemIdentities))) |
|---|
| 348 | (if (getf ids :subjectIdentifiers) |
|---|
| 349 | (elephant:get-instance-by-value |
|---|
| 350 | 'd:PersistentIdC 'd:uri (first (getf ids :subjectIdentifiers))) |
|---|
| 351 | (when (getf ids :subjectLocators) |
|---|
| 352 | (elephant:get-instance-by-value |
|---|
| 353 | 'd:SubjectLocatorC 'd:uri |
|---|
| 354 | (first (getf ids :subjectLocators)))))))) |
|---|
| 355 | (when identifier |
|---|
| 356 | (d:identified-construct identifier :revision revision))))) |
|---|
