diff --git a/README.md b/README.md index 1827a9d..a50bdc1 100644 --- a/README.md +++ b/README.md @@ -396,6 +396,76 @@ Using the `:scopes` parameter notation it is possible to provide multiple scope :scopes '("http://services.semantic.works/people-service" "http://services.semantic.works/another-service")) ``` + +### Defining an authorization policy in ODRL + +> [!WARNING] +> Support for ODRL policies is under development and some functionality, such as using scopes, is not yet (fully) supported. + +This service also supports defining policies using [ODRL](https://www.w3.org/TR/odrl-model/), as an alternative to the lisp-style configuration illustrated above. To enable ODRL policies, set `*use-odrl-config-p*` to non-nil in the config file mounted in `./config/authorization/config.lisp` as shown below. Note, other service configuration settings, such as `*backend*`, should still be set in the same file. + +```lisp +;;;;;;;;;;;;;;;;;;; +;;; delta messenger +(in-package :delta-messenger) + +(add-delta-logger) +(add-delta-messenger "http://delta-notifier/") + +;;;;;;;;;;;;;;;;; +;;; configuration +(in-package :client) +(setf *log-sparql-query-roundtrip* t) +(setf *backend* "http://triplestore:8890/sparql") + +(in-package :server) +(setf *log-incoming-requests-p* nil) + +(in-package :odrl-config) +(setf *use-odrl-config-p* t) +``` + +The actual policy should be defined in [n-triples](https://www.w3.org/TR/n-triples/) format in a config file mounted in `./config/authorization/config.nt`. The following snippet contains the ODRL equivalent, encoded in ttl format, for the lisp access rights shown in the previous section. Note, to use this policy it should be converted from ttl to n-triples. A more comprehensive policy example can be found in the [test config]('./test/exmaple-config.ttl'). + +```ttl +@prefix ext: . +@prefix odrl: . +@prefix sh: . +@prefix vcard: . + +ext:examplePolicy a odrl:Set ; + odrl:permission ext:publicRead , + ext:publicWrite. + +ext:publicGraph a odrl:AssetCollection ; + vcard:fn "public" ; + ext:graphPrefix . + +ext:genericAsset a odrl:Asset , sh:NodeShape ; + odrl:partOf ext:publicGraph ; + sh:targetClass ext:all . + +ext:publicParty a odrl:PartyCollection ; + vcard:fn "public" . + +ext:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target ext:publicGraph ; + odrl:assignee ext:publicParty . + +ext:publicWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target ext:publicGraph ; + odrl:assignee ext:publicParty . +``` + + +The following functionality is *not* yet supported when using an ODRL policy: +- Read policy from a ttl file instead of an n-triples file. Support ttl files is planned, the use of n-triples files is a temporary workaround due to lack of ttl parser in common lisp. +- Specifying `scopes` for a permission. +- Specifying an explicit `constraint` for an `allowed-group`, currently this is implicitly set based on whether a query is provided or not. +- Specifying options, such as whether to generate deltas, per graph definition. + ## Reference ### ACL configuration interface #### `define-graph` diff --git a/launch-sparql-parser.sh b/launch-sparql-parser.sh index 94a9399..6182428 100755 --- a/launch-sparql-parser.sh +++ b/launch-sparql-parser.sh @@ -1,6 +1,6 @@ #!/bin/bash mkdir -p /config -cp /config/*.lisp /app/config/ +cp /config/*.{lisp,nt} /app/config/ exec /usr/src/startup.sh diff --git a/odrl/load-config.lisp b/odrl/load-config.lisp new file mode 100644 index 0000000..d48da78 --- /dev/null +++ b/odrl/load-config.lisp @@ -0,0 +1,13 @@ +(in-package :cl-user) + +(when odrl-config::*use-odrl-config-p* + (format t "~& >> Loading configuration via ODRL") + ;; TODO: this is dirty + ;; Remove any configuration that was loaded by evaluating lisp config + (setf acl::*access-specifications* nil) + (setf acl::*graphs* nil) + (setf acl::*rights* nil) + ;; Load ODRL, if any + (alexandria:if-let ((triples (odrl-config::load-policy-file))) + (odrl-config::odrl-to-acl (odrl-config::make-rule-set triples)) + (format t "~&~%~%NO ODRL CONFIG MOUNTED; BOOTING WITH EMPTY CONFIGURATION~%~%"))) diff --git a/odrl/odrl.lisp b/odrl/odrl.lisp new file mode 100644 index 0000000..e6e27db --- /dev/null +++ b/odrl/odrl.lisp @@ -0,0 +1,230 @@ +(in-package :odrl-config) + +(defparameter *use-odrl-config-p* nil + "Non-nil means the service should load its policy from a file containing an ODRL policy.") + +;; ODRL information model +;; +;; An implementation of a simplified version of the ODRL information model. This implementation is +;; intended to cover the parts of ODRL we currently need, and is not intended to support the entire +;; information model. For example, this only supports Sets and Permissions, and no other types of +;; policies or rules. Similarly, Constraints are not supported at all. +;; +;; Furthermore, this implementation explicitly deviates from ODRL's specification in some ways. +;; Consult the documentation of individual classes for more information. +(defclass concept () + ((uri :initarg :uri + :reader uri)) + (:documentation "Base class for ODRL concepts.")) + +(defclass policy (concept) + ((rules :initarg :rules + :type list + :reader rules)) ; odrl:permission + (:documentation "An ODRL Policy consisting of a set of rules.")) + +(defclass rule-set (policy) + () + (:documentation "An ODRL Set that represents any set of rules.")) + +;; TODO: Should probably replace it by something more robust. +(defun to-kebab-case (str) + "Convert a STR to kebab case. + +Note, this is a simplified version that does *not* split camel case, any upper case letters will +simply be down cased." + (string-downcase (cl-ppcre:regex-replace-all "\\s+|_" str "-"))) + +;; TODO: `supply-allowed-group' allows to specify a `constraint' argument. Currently the value for +;; `constraint' will be implicitly set based on whether there is a `query' specified. Consequently, +;; it is not possible to +;; - specify `NEVER' as value for `constraint'; and +;; - overwrite the presence of a `query' by explicitly specifying `ALWAYS' (or `NEVER') as value for +;; `constraint'. +(defclass party-collection (concept) + ((name :initarg :name + :reader name) ; vcard:fn + (description :initarg :description + :initform nil + :reader description) ; ext:description + (parameters :initarg :parameters + :initform nil + :reader parameters) ; ext:queryParameters + (query :initarg :query + :initform nil + :reader query)) ; ext:definedBy + (:documentation "An ODRL party collection. In contrast to the ODRL specification this does not explicitly contain member parties. Instead members are essentially defined by the query, if the query returns a result the (implied) party is considered a member of the party collection.")) + +(defmethod initialize-instance :after ((concept party-collection) &key) + (setf (slot-value concept 'name) (to-kebab-case (name concept)))) + +;; TODO: `define-graph' allows to specify extra options `:sparql' and `:delta'. The ODRL policy +;; currently does not allow such options to be passed. Should extend data model to support this if +;; we want to achieve full compatibility with the lisp configuration interface. +(defclass asset-collection (concept) + ((name :initarg :name + :type string + :reader name) ; vcard:fn + (description :initarg :description + :initform nil + :reader description) ; dct:description + (graph :initarg :graph + :reader graph) ; ext:graphPrefix + (assets :initarg :assets + :type list ; of `shacl:node-shape's + :reader assets)) ; ^odrl:partOf + (:documentation "An ODRL Asset collection representing a graph. In contrast to the ODRL specification this does explicitly refer to its contained assets, thereby modelling the inverse of the ODRL's partOf predicate. This inversion simplifies converting ODRL policies to ACL configurations as it allows to iterate of the necessary assets when given an asset collection, which is in turn referenced by a rule for the starting point of the ODRL to ACL conversion. Otherwise, one would somehow have to keep track of all asset instances and link them their collections. A consequence of this is that the entity creating `asset-collection' instances is responsible for inverting the relations between assets and the asset collections they part of. Furthermore, assets are represented as instances of `shacl:node-shape' and there is *no* explicit class for ODRL Assets.")) + +(defmethod initialize-instance :after ((concept asset-collection) &key) + (setf (slot-value concept 'name) (to-kebab-case (name concept)))) + +(defclass rule (concept) + ((actions :initarg :actions + :type list + :reader actions) ; odrl:action + (target :initarg :target + :type asset-collection + :reader target) ; odrl:target + (assignee :initarg :assignee + :type party-collection + :reader assignee)) ; odrl:assignee + (:documentation "An ODRL rule combines the common parts for permissions, prohibitions, and duties. In contrast to the ODRL specification we allow a rule to specify multiple actions, as `acl::access-grant's allows multiple usages to be specified.")) + +(defclass permission (rule) + () + (:documentation "An ODRL permission represents that an assignee is allowed to perform an action on a target.")) + +(defclass action (concept) + () + (:documentation "An ODRL Action class which indicates an operation that can be performed on an asset. The actual operation should be encoded in the URI of the action element. Note that the conversion to ACL currently only supports two actions: `odrl:read' and `odrl:modify', specifying any other action will lead to errors.")) + + +;; +;; Conversion to sparql-parser's ACL +;; +(defgeneric odrl-to-acl (concept) + (:documentation "Convert an ODRL concept to its corresponding sparql-parser configuration macro.")) + +(defun rules-match-p (left right) + "Return t if the rules LEFT and RIGHT have the same target and assignee, nil otherwise." + (and (eq (slot-value left 'assignee) (slot-value right 'assignee)) + (eq (slot-value left 'target) (slot-value right 'target)))) + +(defun find-matching-rule (rule rules) + "Find a rule in RULES that `rules-match-p' RULE." + (find-if (lambda (r) (rules-match-p r rule)) rules)) + +(defun reduce-rules (rules) + "Reduce RULES by merging together rules that have the same assignee and target." + (let ((reduced-rules '())) + (mapcar + (lambda (rule) + (let ((matching-rule (find-matching-rule rule reduced-rules))) + (if matching-rule + (setf (slot-value matching-rule 'actions) + (union (slot-value matching-rule 'actions) + (slot-value rule 'actions))) + (push rule reduced-rules)))) + rules) + reduced-rules)) + +(defmethod odrl-to-acl ((concept rule-set)) + (with-slots (rules) concept + (let ((party-collections (mapcar (lambda (r) (slot-value r 'assignee)) rules)) + (asset-collections (mapcar (lambda (r) (slot-value r 'target)) rules))) + ;; NOTE (20/01/2026): Party and Asset Collections that are not referenced by a rule are not + ;; converted to their respective access specifications or graph specifications. Consequently, + ;; no specifications for such collections are added the service's internal state. This differs + ;; from the situation with a Lisp configuration where all defined specifications are + ;; evaluated, irrelevant whether they are used in a grant. + (handler-case + (progn + (mapcar #'odrl-to-acl (remove-duplicates party-collections)) + (mapcar #'odrl-to-acl (remove-duplicates asset-collections)) + ;; NOTE (24/01/2026): The `reduce-rules' merges rules that have the same assignee and + ;; target. These mergers allow to convert each rule to a single access-grant. + (mapcar #'odrl-to-acl (reduce-rules rules))) + (error (e) + (format t "~%Error: Could not parse the loaded ODRL policy: ~A~%" e)))))) + +(defmethod odrl-to-acl ((concept asset-collection)) + (with-slots (name graph assets) concept + (acl::define-graph* + :name (read-from-string name) + :graph graph + ;; TODO: set actual values, cf. `define-graph' macro, requires actually getting this as input + :options '(:delta t :sparql t) + :type-specifications (mapcar #'shacl-to-acl assets)))) + +(defmethod odrl-to-acl ((concept party-collection)) + (with-slots (name description parameters query) concept + (acl:supply-allowed-group name :query query :parameters parameters))) + +;; TODO: This partially replicates the logic in the `acl:grant' macro +(defmethod odrl-to-acl ((concept permission)) + (with-slots (actions target assignee) concept + (acl:grant* + :scopes (list 'acl:_) ;; TODO: support scopes + :rights (mapcar + (lambda (action) + (intern (symbol-name (odrl-to-acl action)) :keyword)) + actions) + :graph-specs (list (read-from-string (slot-value target 'name))) + :allowed-groups (list (slot-value assignee 'name))))) + +(defmethod odrl-to-acl ((concept action)) + (with-slots (uri) concept + (cond + ((cl-ppcre:scan ".*read>?$" uri) 'acl::read) + ((cl-ppcre:scan ".*modify>?$" uri) 'acl::write) + ;; NOTE (23/01/2026): The odrl:write action was deprecated by odrl:modify. We will support it + ;; anyway for convenience. + ((cl-ppcre:scan ".*write>?$" uri) 'acl::write) + (t (error "No matching right found for \"~a\"" uri))))) + +;; +;; Varia +;; +(defmethod print-object ((object rule-set) stream) + (print-unreadable-object (object stream) + (with-slots (uri rules) object + (format + stream + "~a <~a>~&~2t" + (type-of object) + uri + (mapcar #'uri rules))))) + +(defmethod print-object ((object rule) stream) + (print-unreadable-object (object stream) + (format stream "~a" (uri object)))) + +(defmethod print-object ((concept action) stream) + (print-unreadable-object (concept stream) + (format stream "~a" (uri concept)))) + +(defmethod print-object ((object asset-collection) stream) + (print-unreadable-object (object stream) + (with-slots (uri name description graph assets) object + (format + stream + "~a ~a~&~2t~&~2t~&~2t~&~2t" + (type-of object) + uri + name + description + graph + assets)))) + +(defmethod print-object ((object party-collection) stream) + (print-unreadable-object (object stream) + (with-slots (uri name description parameters query) object + (format + stream + "~a ~a~&~2t~&~2t~&~2t~&~2t" + (type-of object) + uri + name + description + parameters + query)))) diff --git a/odrl/parse-ntriples.lisp b/odrl/parse-ntriples.lisp new file mode 100644 index 0000000..de4f184 --- /dev/null +++ b/odrl/parse-ntriples.lisp @@ -0,0 +1,332 @@ +(in-package :odrl-config) + +;; Read policy files +;; +;; Read an ODRL policy specified as n-triples in a file and convert the parsed triples to a +;; `rule-set'. +;; NOTE (23/01/2026): This is rather messy code, but once we can directly read and parse ttl files +;; at part of it should become unnecessary. The need to read and parse n-triples is due to a lack of +;; a ttl parser in common lisp. We plan to fill that gap in the future. + +(defun policy-file (&optional filename) + "Get the path to the file to read the ODRL policy from. + +If FILENAME is nil, fall back to the \"config\" as default name for the policy file." + (if (find :docker *features*) + (concatenate 'string "../config/" (or filename "config") ".nt") + "test/example-config.nt")) + +(defun read-ntriples-file (path) + "Read the n-triples file `policy-file' and return its contents as a single string." + (let ((path (asdf:system-relative-pathname :sparql-parser path))) + (alexandria:read-file-into-string path))) + +(defun load-policy-file (&optional filename) + "Read the ODRL policy from FILENAME." + (handler-case + (let ((path (policy-file filename))) + (format t "~& >> INFO: Reading ODRL policy from ~A" path) + (nt:parse-nt (read-ntriples-file path))) + (error (e) + (format t "~& >> WARN: An error occurred when trying to read the configuration file: ~% >>>> '~A'~%" e)))) + +;; Utilities +(defparameter predicates-plist + '(:dcterms-description "http://purl.org/dc/terms/description" + :ext-defined-by "http://mu.semte.ch/vocabularies/ext/definedBy" + :ext-graph-prefix "http://mu.semte.ch/vocabularies/ext/graphPrefix" + :ext-query-parameters "http://mu.semte.ch/vocabularies/ext/queryParameters" + :odrl-action "http://www.w3.org/ns/odrl/2/action" + :odrl-assignee "http://www.w3.org/ns/odrl/2/assignee" + :odrl-assigner "http://www.w3.org/ns/odrl/2/assigner" + :odrl-part-of "http://www.w3.org/ns/odrl/2/partOf" + :odrl-permission "http://www.w3.org/ns/odrl/2/permission" + :odrl-profile "http://www.w3.org/ns/odrl/2/profile" + :odrl-target "http://www.w3.org/ns/odrl/2/target" + :rdf-type "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" + :sh-inverse-path "http://www.w3.org/ns/shacl#inversePath" + :sh-not "http://www.w3.org/ns/shacl#not" + :sh-path "http://www.w3.org/ns/shacl#path" + :sh-property "http://www.w3.org/ns/shacl#property" + :sh-target-class "http://www.w3.org/ns/shacl#targetClass" + :vcard-fn "http://www.w3.org/2006/vcard/ns#fn") + "A plist containing the full uris for the predicates that are used in ODRL policies.") + +(defun predicate-uri (indicator) + "Return a string containing the full uri for the predicate matching INDICATOR." + (getf predicates-plist indicator)) + +(defparameter resource-types-plist + '(:odrl-asset "http://www.w3.org/ns/odrl/2/Asset" + :odrl-asset-collection "http://www.w3.org/ns/odrl/2/AssetCollection" + :odrl-party "http://www.w3.org/ns/odrl/2/Party" + :odrl-party-collection "http://www.w3.org/ns/odrl/2/PartyCollection" + :odrl-permission "http://www.w3.org/ns/odrl/2/Permission" + :odrl-profile "http://www.w3.org/ns/odrl/2/Profile" + :odrl-set "http://www.w3.org/ns/odrl/2/Set" + :sh-node-shape "http://www.w3.org/ns/shacl#NodeShape" + :sh-property-shape "http://www.w3.org/ns/shacl#PropertyShape") + "A plist containing the full uris for the resources types used in ODRL policies.") + +(defun type-uri (indicator) + "Return a string containing the full uri for the resource type matching INDICATOR." + (getf resource-types-plist indicator)) + +;; +;; Utilities to simplify parsing triples +;; +(defun value-from-object (object) + "Return the value of the OBJECT as a string. + +OBJECT is assumed to be an object as created by cl-ntriples. For any other kind of input the result +will be NIL." + (or (getf object :object-uriref) + (getf object :object-node-id) + (getf object :literal-string))) + +(defun triple-subject (triple) + "Return the subject of TRIPLE as a string." + (first triple)) + +(defun triple-predicate (triple) + "Return the predicate of TRIPLE as a string." + (second triple)) + +(defun triple-object (triple) + "Return the cl-ntriples object that is the object of TRIPLE." + (third triple)) + +(defun triple-object-value (triple) + "Return the value of the TRIPLE's object as a string." + (value-from-object (triple-object triple))) + +(defun triples-for-predicate (predicate triples) + "Return all elements in TRIPLES that have PREDICATE as predicate value." + (remove-if-not + (lambda (triple) (string= predicate (triple-predicate triple))) + triples)) + +(defun triples-for-resource (resource triples) + "Return an triple objects in TRIPLES that have RESOURCE as subject." + (remove-if-not + (lambda (triple) (string= resource (triple-subject triple))) + triples)) + +(defun triples-for-resource-predicate (resource predicate triples) + "Return all triple objects in TRIPLES that have RESOURCE as subject and PREDICATE as predicate." + (remove-if-not + (lambda (triple) + (and (string= resource (triple-subject triple)) + (string= predicate (triple-predicate triple)))) + triples)) + +(defun triples-for-predicate-object (predicate object triples) + "Return all triple objects in TRIPLES that have PREDICATE as predicate and OBJECT as object." + (remove-if-not + (lambda (triple) + (and (string= predicate (triple-predicate triple)) + (string= object (triple-object-value triple)))) + triples)) + +(defun list-parts-in-collection (uri triples) + "Return a list of the uris of all resources that are a part of the collection resource URI in TRIPLES." + (let ((parts (triples-for-predicate-object (predicate-uri :odrl-part-of) uri triples))) + (mapcar #'triple-subject parts))) + +(defun filter-resources-for-type (type triples) + "Filter the type triples for resources of TYPE in TRIPLES. + +TYPE should be a string containing a uri for a resource type." + (remove-if-not + (lambda (triple) (string= type (triple-object-value triple))) + (triples-for-predicate (predicate-uri :rdf-type) triples))) + +(defun list-resource-uris (type triples) + "Return a list containing the uri of each resource of TYPE in TRIPLES." + (mapcar #'triple-subject (filter-resources-for-type type triples))) + +(defun list-party-collections (triples) + "List the uris for ODRL party collection resources in TRIPLES." + (list-resource-uris (type-uri :odrl-party-collection) triples)) + +(defun list-asset-collections (triples) + "List the uris for ODRL asset collection resources in TRIPLES." + (list-resource-uris (type-uri :odrl-asset-collection) triples)) + +(defun list-assets (triples) + "List the uris for ODRL asset resources in TRIPLES." + (list-resource-uris (type-uri :odrl-asset) triples)) + +(defun list-permissions-in-policy (triples) + "Return a list of the uris of all permissions in the policy defined by TRIPLES." + (mapcar + (lambda (triple) (triple-object-value triple)) + (triples-for-predicate (predicate-uri :odrl-permission) triples))) + +;; NOTE (01/10/2025): These macros are use to make the init-forms in the `let' operators in the +;; conversion functions more readable. +(defmacro first-value-for-predicate (predicate triples) + "Return the value of the first object for PREDICATE encountered in TRIPLES." + `(triple-object-value (car (triples-for-predicate ,predicate ,triples)))) + +(defmacro first-triple-for-resource (uri triples) + "Return the first triple with URI as subject in TRIPLES." + `(car (triples-for-resource ,uri ,triples))) + +(defun find-policy-uri (triples) + "Find the uri for the policy resource defined in TRIPLES." + (car (list-resource-uris (type-uri :odrl-set) triples))) + +;; +;; Conversion to ODRL +;; +(defun find-concept-with-uri (uri concepts) + "Find the concept instance in CONCEPTS that has URI as value for its uri slot." + (when uri + (find-if + (lambda (concept) (string= (slot-value concept 'uri) uri)) + concepts))) + +(defun find-shape-with-uri (uri shapes) + "Find the shape instance in SHAPES that has URI as value for its uri slot." + (when uri + (find-if + (lambda (shape) (string= (slot-value shape 'uri) uri)) + shapes))) + +(defun make-rule-set (triples) + "Make an `rule-set' instance for the resource with URI." + (let ((asset-collections (make-asset-collections triples)) + (party-collections (make-party-collections triples)) + (permissions (list-permissions-in-policy triples))) + (make-instance + 'rule-set + :uri (find-policy-uri triples) + :rules (mapcar + (lambda (permission) + (make-permission permission asset-collections party-collections triples)) + permissions)))) + +(defun make-party-collections (triples) + "Make an `party-collection' for each party collection resource in TRIPLES." + (mapcar + (lambda (uri) (make-party-collection uri triples)) + (list-party-collections triples))) + +(defun make-party-collection (uri policy-triples) + "Make an `party-collection' instance for the resource with URI." + (let* ((triples (triples-for-resource uri policy-triples)) + (name (first-value-for-predicate (predicate-uri :vcard-fn) triples)) + (description (first-value-for-predicate (predicate-uri :dcterms-description) triples)) + (parameters (triples-for-predicate (predicate-uri :ext-query-parameters) triples)) + (query (first-value-for-predicate (predicate-uri :ext-defined-by) triples))) + (make-instance + 'party-collection + :uri uri + :name name + :description description + :parameters (mapcar #'triple-object-value parameters) + ;; TODO: Make sure to remove any newlines and/or trailing spaces at the end of the string; + ;; otherwise it will not be parsed correctly + ;; Also remove any newlines at the beginning of the string + :query query))) + +(defun make-asset-collections (triples) + "Make an `asset-collection' for each asset collection resource in TRIPLES." + (let ((assets (make-node-shapes triples))) + (mapcar + (lambda (uri) (make-asset-collection uri assets triples)) + (list-asset-collections triples)))) + +(defun make-asset-collection (uri assets policy-triples) + "Make an `asset-collection' instance for the resource with URI." + (let* ((triples (triples-for-resource uri policy-triples)) + (name (first-value-for-predicate (predicate-uri :vcard-fn) triples)) + (description (first-value-for-predicate (predicate-uri :dcterms-description) triples)) + (graph (first-value-for-predicate (predicate-uri :ext-graph-prefix) triples)) + (assets-in-collection (list-parts-in-collection uri policy-triples))) + (make-instance + 'asset-collection + :uri uri + :name name + :description description + :graph graph + :assets (mapcar + (lambda (uri) (find-shape-with-uri uri assets)) + assets-in-collection)))) + +(defun make-node-shapes (triples) + "Make a `node-shape' instance for each ODRL asset resource in triples." + (mapcar + (lambda (uri) (make-node-shape uri triples)) + (list-assets triples))) + +(defun make-node-shape (uri policy-triples) + "Make a `shacl:node-shape' for the resource with URI." + (let* ((triples (triples-for-resource uri policy-triples)) + (target (first-value-for-predicate (predicate-uri :sh-target-class) triples)) + ;; NOTE (01/10/2025): Node shapes may surround their property shapes with a "sh:not" + ;; constraint component. The `not-triple' will have a non-nil value if that is the case, + ;; otherwise it will be nill. This is used in `properties' to determine whether one has to + ;; go passed an additional blank node or not to find the properties in a node shape. + (not-triple (car (triples-for-predicate (predicate-uri :sh-not) triples))) + (properties (if not-triple + (triples-for-resource-predicate + (triple-object-value not-triple) + (predicate-uri :sh-property) + policy-triples) + (triples-for-predicate (predicate-uri :sh-property) triples)))) + (make-instance + 'node-shape + :uri uri + :target-class target + :properties (mapcar + (lambda (uri) (make-property-shape uri policy-triples)) + (mapcar #'triple-object-value properties)) + :notp (when not-triple t)))) + +(defun blank-node-uri-p (uri) + "Check whether a given URI is for a blank." + ;; TODO(C): match on alphanumeric characters in id part + (cl-ppcre:scan "?" uri)) + +(defun make-property-shape (uri policy-triples) + "Make a `shacl:property-shape' instance for the resource with URI." + (let ((path (triple-object-value (first-triple-for-resource uri policy-triples)))) + (make-instance + 'property-shape + :uri uri + :path (if (blank-node-uri-p path) + (make-property-path path policy-triples) + path)))) + +(defun make-property-path (uri policy-triples) + "Make a `property-path' instance for the resource with URI." + (let* ((triple (first-triple-for-resource uri policy-triples)) + (path (triple-predicate triple)) + (object (triple-object-value triple))) + (make-instance 'property-path :predicate-path path :object object))) + +(defun make-permission (uri asset-col party-col policy-triples) + "Make a `permission' instance for the resource with URI. + +ASSET-COL and PARTY-COL should be lists of, respectively, `asset-collection' and +`party-collection' instances with which the created `permission' instance can be linked." + (let* ((triples (triples-for-resource uri policy-triples)) + (action (first-value-for-predicate (predicate-uri :odrl-action) triples)) + (target (find-concept-with-uri + (first-value-for-predicate (predicate-uri :odrl-target) triples) + asset-col)) + (assignee (find-concept-with-uri + (first-value-for-predicate (predicate-uri :odrl-assignee) triples) + party-col))) + (make-instance + 'permission + :uri uri + :actions (list (make-action action)) + :target target + :assignee assignee))) + +(defun make-action (uri) + "Make an `action' instance for the given URI." + (make-instance 'action :uri uri)) diff --git a/odrl/shacl.lisp b/odrl/shacl.lisp new file mode 100644 index 0000000..3596176 --- /dev/null +++ b/odrl/shacl.lisp @@ -0,0 +1,115 @@ +(in-package :odrl-config) + +;; Shapes Constraint Language (SHACL) +;; +;; A, very, simplified implementation of SHACL. This implementation is strictly limited to the +;; elements of SHACL we need in order to express which triples should be considered part of some +;; asset collection. +(defclass shape () + ((uri :initarg :uri) + (target-class :initarg :target-class + :initform nil + :reader target-class)) ; sh:targetClass + (:documentation "A SHACL shape.")) + +(defclass node-shape (shape) + ((properties :initarg :properties + :initform nil + :reader properties) ; sh:property* + ;; NOTE (04/09/2025): Used to indicate whether the property shapes are surrounded by a + ;; `sh:not'. This is a simplification, ideally we can capture and process constraints + ;; (components) in general. + (notp :initarg :notp + :type boolean + :initform nil + :reader notp)) + (:documentation "A SHACL node shape")) + +(defclass property-shape (shape) + ((path :initarg :path + :initform nil + :reader path)) ; value is a predicate URI or a `property-path' instance + (:documentation "A SHACL property shape")) + +(defclass property-path () + ((predicate-path :initarg :predicate-path + :reader predicate-path) + (object :initarg :object + :reader object)) + (:documentation "A SHACL property path.")) + + +;; +;; Conversion to sparql-parser's ACL +;; +(defgeneric shacl-to-acl (shape &optional notp) + (:documentation "Convert a SHACL shape to its corresponding sparql-parser entity.")) + +(defmethod shacl-to-acl ((shape node-shape) &optional notp) + (declare (ignore notp)) + (with-slots (target-class properties notp) shape + (alexandria:flatten + (append + (list (if (is-empty-node-p target-class) 'acl:_ target-class)) + (if properties + (mapcar (lambda (prop) (shacl-to-acl prop notp)) properties) + '(acl::-> acl:_)))))) + +(defun is-empty-node-p (path) + "Check whether PATH is the special uri for an empty node. + +The special uri was introduced to allow users to specify \"all predicates\" in a policy, as one +would use `_' in a lisp configuration. This special uri was needed because in SHACL property paths +must have a value for their object and otherwise we could not express type specifications of the of +the form `TYPE <- _' or `TYPE ) + (t 'acl::->))) + +(defmethod shacl-to-acl ((shape property-shape) &optional notp) + ;; If value of `path' is + ;; - a URI: (make-... :direction "->" :predicate path) + ;; - a `property-path': + ;; + parse its `predicate-path' to determine value for :direction + ;; + use its `object' as value for :predicate + (with-slots (path) shape + (list + ;; NOTE (13/09/2025): The simplification of using the mere existence of a property path to mean + ;; invert the direction depends on the fact that we use no other property paths than + ;; `sh:inversePath'. This should be generalised to actually check which `predicate-path' is + ;; used. + (direction-string (typep path 'property-path) notp) + (if (typep path 'property-path) + (if (is-empty-node-p (object path)) 'acl:_ (object path)) + (if (is-empty-node-p path) 'acl:_ path))))) + +;; +;; Varia +;; +(defmethod print-object ((shape node-shape) stream) + (print-unreadable-object (shape stream) + (with-slots (uri target-class properties notp) shape + (format + stream + "~a <~a>~&~2t~&~2t~&~2t" + (type-of shape) + uri + target-class + notp + properties)))) + +(defmethod print-object ((shape property-shape) stream) + (print-unreadable-object (shape stream) + (with-slots (uri path) shape + (format stream "~a <~a>~&~4t" (type-of shape) uri path)))) + +(defmethod print-object ((path property-path) stream) + (print-unreadable-object (path stream) + (with-slots (predicate-path object) path + (format stream "~a <~a> <~a>" (type-of path) predicate-path object)))) diff --git a/packages.lisp b/packages.lisp index fa091e3..551f704 100644 --- a/packages.lisp +++ b/packages.lisp @@ -151,6 +151,9 @@ (defpackage #:acl-config (:use :common-lisp)) +(defpackage #:odrl-config + (:use :common-lisp)) + (defpackage #:prefix (:use :common-lisp) (:export #:expand diff --git a/sparql-parser.asd b/sparql-parser.asd index 802c378..28c4587 100644 --- a/sparql-parser.asd +++ b/sparql-parser.asd @@ -6,7 +6,7 @@ :license "MIT" :description "Parser for the SPARQL1.1 specification." :serial t - :depends-on (alexandria cl-ppcre bordeaux-threads woo dexador jsown luckless sha1 trivial-backtrace flexi-streams) + :depends-on (alexandria cl-ppcre bordeaux-threads woo dexador jsown luckless sha1 trivial-backtrace flexi-streams cl-ntriples) :components ((:file "packages") ;; supporting code (:file "support/support") @@ -37,6 +37,10 @@ (:file "acl/acl") (:file "acl/configuration-interface") (:file "acl/config") + ;; ODRL configuration + (:file "odrl/parse-ntriples") + (:file "odrl/odrl") + (:file "odrl/shacl") ;; ;; reasoning to determine graphs ;; (:file "reasoner/tree-mirror") ;; (:file "reasoner/prefixes") @@ -61,4 +65,5 @@ ;; administration (:file "administration/string-files") ;; configuration - (:file "config/config"))) + (:file "config/config") + (:file "odrl/load-config"))) diff --git a/test/example-config.nt b/test/example-config.nt new file mode 100644 index 0000000..cf6cb68 --- /dev/null +++ b/test/example-config.nt @@ -0,0 +1,96 @@ + . + . + . + . + . + . + . + . + . + . + . + "PREFIX session: \n PREFIX mu: \n PREFIX ext: \n SELECT ?account WHERE {\n session:account ?account.\n ?account ext:hasRole ext:Administrator.\n }" . + . + . + . + . + "admin" . + . + . + . + . + . + . + . + . + . + . + . + "id" . + . + . + . + . + . + . + "public-data" . + . + . + . + . + . + . + "user-data" . + . + . + . + . + . + . + . + . + . + . + "public" . + . + . + . + . + . + . + . + . + "PREFIX session: \n PREFIX mu: \n SELECT ?id WHERE {\n session:account/mu:uuid ?id.\n }" . + . + . + . + . + . + . + "push-updates" . + . + . + . + . + . + . + . + "user" . + . + . + . + . + . + . + . + . + . + . + . + . + . + . + . + . + . + . diff --git a/test/example-config.ttl b/test/example-config.ttl new file mode 100644 index 0000000..c39761d --- /dev/null +++ b/test/example-config.ttl @@ -0,0 +1,132 @@ +@prefix authors: . +@prefix books: . +@prefix example: . +@prefix ext: . +@prefix favorites: . +@prefix foaf: . +@prefix geo: . +@prefix odrl: . +@prefix push: . +@prefix schema: . +@prefix sh: . +@prefix vcard: . + +example:examplePolicy a odrl:Set ; + odrl:permission example:adminPublicRead , + example:adminPublicWrite , + example:publicRead , + example:userUserDataRead , + example:userUserDataWrite , + example:publicPushUpdatesRead , + example:publicPushUpdatesWrite . + +example:publicParty a odrl:PartyCollection ; + vcard:fn "public" . + +example:authenticatedUserParty a odrl:PartyCollection ; + vcard:fn "user" ; + ext:definedBy """PREFIX session: + PREFIX mu: + SELECT ?id WHERE { + session:account/mu:uuid ?id. + }""" ; + ext:queryParameters "id" . + +example:adminParty a odrl:PartyCollection ; + vcard:fn "admin" ; + ext:definedBy """PREFIX session: + PREFIX mu: + PREFIX ext: + SELECT ?account WHERE { + session:account ?account. + ?account ext:hasRole ext:Administrator. + }""" . + + +example:publicGraph a odrl:AssetCollection ; + vcard:fn "public-data" ; + ext:graphPrefix . + +example:userGraph a odrl:AssetCollection ; + vcard:fn "user-data" ; + ext:graphPrefix . + +# TODO: Additional options provided: `:delta t :sparql nil` +example:pushUpdatesGraph a odrl:AssetCollection ; + vcard:fn "push-updates" ; + ext:graphPrefix . + + +example:personAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:publicGraph ; + sh:targetClass foaf:Person . + +example:personeFavoriteAuthorAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:userGraph ; + sh:targetClass foaf:Person ; + sh:property [ + sh:path [ sh:inversePath ext:hasFavoriteAuthor ] + ] . + +example:bookAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:publicGraph ; + sh:targetClass schema:Book . + +example:geometryAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:publicGraph ; + sh:targetClass geo:Geometry . + +example:WildCardAssset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:userGraph ; + sh:targetClass ext:all ; + sh:property [ sh:path ext:hasBook ] , + [ sh:path ext:hasSuperFavorite ] , + [ sh:path ext:longContent ] . + +example:noNameOrLabelAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:userGraph ; + sh:targetClass ext:NoNameOrLabel ; + sh:not [ + sh:property [ sh:path ext:name ] , + [ sh:path ext:label ] + ] . + +example:updateAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:pushUpdatesGraph ; + sh:targetClass push:Update . + + +example:adminPublicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:publicGraph ; + odrl:assignee example:adminParty . + +example:adminPublicWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:publicGraph ; + odrl:assignee example:adminParty . + +example:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:publicGraph ; + odrl:assignee example:publicParty . + +example:userUserDataRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:userGraph ; + odrl:assignee example:authenticatedUserParty . + +example:userUserDataWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:userGraph ; + odrl:assignee example:authenticatedUserParty . + +example:publicPushUpdatesRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:pushUpdatesGraph ; + odrl:assignee example:publicParty . + +example:publicPushUpdatesWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:pushUpdatesGraph ; + odrl:assignee example:publicParty . diff --git a/test/scenario.lisp b/test/scenario.lisp index 2b1b824..bcf1630 100644 --- a/test/scenario.lisp +++ b/test/scenario.lisp @@ -177,6 +177,45 @@ ,@body)) +;; TODO: Copied and modified from `with-acl-config', could probably reduce the code duplication +(defmacro with-odrl-config (&body body) + "Executes body with the access rights specification required for these tests." + `(let ((prefix::*prefixes* nil) + (acl::*access-specifications* nil) + (acl::*graphs* nil) + (acl::*rights* nil) + (delta-messenger::*delta-handlers* nil) + (client::*backend* "http://localhost:8891/sparql") + (client::*log-sparql-query-roundtrip* t) + (type-cache::*uri-graph-user-type-providers* nil) + (quad-transformations::*user-quad-transform-functions* nil)) + + (type-cache::add-type-for-prefix "http://book-store.example.com/books/" "http://schema.org/Book") + + (quad-transformations:define-quad-transformation (quad method) + ;; make quad objects which have datatype in uuid specification just strings + (if (and + ;; predicate is uuid + (string= (quad-term:uri (quad:predicate quad)) + "http://mu.semte.ch/vocabularies/core/uuid") + ;; object has datatype + (= (length (sparql-parser:match-submatches (quad:object quad))) 3)) + (let ((new-quad (quad:copy quad))) ; make new quad + (setf (quad:object new-quad) + (sparql-manipulation:make-nested-match + `(ebnf::|RDFLiteral| ,(first (sparql-parser:match-submatches (quad:object quad)))))) + ;; use the new quad + (quad-transformations:update new-quad)) + ;; otherwise keep it + (quad-transformations:keep))) + + ;; Read and load configuration from example file containing ODRL policy + (odrl-config::odrl-to-acl + (odrl-config::make-rule-set + (odrl-config::load-policy-file))) + + ,@body)) + (defmacro with-impersonation-for (user &body body) "Impersonates USER." `(server::with-call-context @@ -212,17 +251,14 @@ this point and likely a redpencil image too.") ;;;; Scenario ;;;; Boot up a container using: ;;;; docker run --name virtuoso -p 8891:8890 -e SPARQL_UPDATE=true -e "DEFAULT_GRAPH=http://mu.semte.ch/application" redpencil/virtuoso:1.2.0-rc.1; dr rm virtuoso -(defun run-assertion-tests () - (clean-up-graphs) - (store-initial-session-data) - - (with-acl-config - (format t "~&Joll is an administrator.~%") - (with-impersonation-for :joll - (format t "~&Can add authors.~%") - - (server:execute-query-for-context - "PREFIX foaf: +(defun assertion-tests () + "Set of assertions tests for this service." + (format t "~&Joll is an administrator.~%") + (with-impersonation-for :joll + (format t "~&Can add authors.~%") + + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: @@ -235,9 +271,9 @@ this point and likely a redpencil image too.") foaf:name \"Daniel Kahneman\". }") - (format t "~&Can add authors. (2)~%") - (server:execute-query-for-context - "PREFIX foaf: + (format t "~&Can add authors. (2)~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -254,10 +290,10 @@ this point and likely a redpencil image too.") schema:creator authors:daniel. }") - (format t "~&Can add extra book for author.~%") + (format t "~&Can add extra book for author.~%") - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -268,10 +304,10 @@ this point and likely a redpencil image too.") schema:creator authors:david . }") - (format t "~&Can add extra author to book.~%") + (format t "~&Can add extra author to book.~%") - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -282,12 +318,12 @@ this point and likely a redpencil image too.") books:abundance schema:creator authors:steven, authors:peter. }")) - (with-impersonation-for :jack - (format t "~&Jack is a user.~%") + (with-impersonation-for :jack + (format t "~&Jack is a user.~%") - (format t "~&Jack can add a favorite.~%") - (server:execute-query-for-context - "PREFIX foaf: + (format t "~&Jack can add a favorite.~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -298,10 +334,10 @@ this point and likely a redpencil image too.") favorites:me ext:hasBook books:gtd, books:fastAndSlow. }") - ;; jack likes all authors of the book Abundance - (format t "~&Jack can add conditional favorite authors.~%") - (server:execute-query-for-context - "PREFIX foaf: + ;; jack likes all authors of the book Abundance + (format t "~&Jack can add conditional favorite authors.~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -313,12 +349,12 @@ this point and likely a redpencil image too.") } WHERE { books:abundance schema:creator ?author. }") - ;; this data has no place to live, the target must be a foaf:Person and it is a book. - (format t "~&Jack can't add books as favorite author.~%") - (handler-case - (progn - (server:execute-query-for-context - "PREFIX foaf: + ;; this data has no place to live, the target must be a foaf:Person and it is a book. + (format t "~&Jack can't add books as favorite author.~%") + (handler-case + (progn + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -330,12 +366,12 @@ this point and likely a redpencil image too.") } WHERE { books:abundance schema:creator/^schema:creator ?book. }") - (format t "~&ERROR: Oh noes, Jack shouldn't be allowed to do add a book as an author!~%")) - (error (e) (declare (ignore e)) t)) - ;; let's check if jack has favorite authors - (format t "~&Jack can ask for favorite authors.~%") - (server:execute-query-for-context - "PREFIX foaf: + (format t "~&ERROR: Oh noes, Jack shouldn't be allowed to do add a book as an author!~%")) + (error (e) (declare (ignore e)) t)) + ;; let's check if jack has favorite authors + (format t "~&Jack can ask for favorite authors.~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -345,10 +381,10 @@ this point and likely a redpencil image too.") ASK { favorites:me ext:hasFavoriteAuthor ?author. }") - ;; then let's describe the values - (format t "~&Jack can describe favorite authors.~%") - (server:execute-query-for-context - "PREFIX foaf: + ;; then let's describe the values + (format t "~&Jack can describe favorite authors.~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -359,11 +395,11 @@ this point and likely a redpencil image too.") favorites:me ext:hasFavoriteAuthor ?author. }") - ;; now let's replace the favorite author in two queries rather - ;; than in one - (format t "~&Jack can execute delete where and insert data in one query.~%") - (server:execute-query-for-context - "PREFIX foaf: + ;; now let's replace the favorite author in two queries rather + ;; than in one + (format t "~&Jack can execute delete where and insert data in one query.~%") + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -381,37 +417,37 @@ this point and likely a redpencil image too.") } }")) - (with-impersonation-for :joll - (quad-transformations:define-quad-transformation (quad method) - ;; fix wktLiteral string representation - (let* ((object (quad:object quad)) - (datatype-match (and - (sparql-parser:match-p object) + (with-impersonation-for :joll + (quad-transformations:define-quad-transformation (quad method) + ;; fix wktLiteral string representation + (let* ((object (quad:object quad)) + (datatype-match (and + (sparql-parser:match-p object) + (eq (sparql-parser:match-term object) 'ebnf::|RDFLiteral|) + (= 3 (length (sparql-parser:match-submatches object))) + (third (sparql-parser:match-submatches object)))) + (datatype-uri (and datatype-match + (quad-term:uri + (first + (sparql-parser:match-submatches datatype-match))))) + (string-value (and (sparql-parser:match-p object) (eq (sparql-parser:match-term object) 'ebnf::|RDFLiteral|) - (= 3 (length (sparql-parser:match-submatches object))) - (third (sparql-parser:match-submatches object)))) - (datatype-uri (and datatype-match - (quad-term:uri - (first - (sparql-parser:match-submatches datatype-match))))) - (string-value (and (sparql-parser:match-p object) - (eq (sparql-parser:match-term object) 'ebnf::|RDFLiteral|) - (sparql-manipulation:string-literal-string - (first (sparql-parser:match-submatches object)))))) - (if (and datatype-uri - (string= "http://www.opengis.net/ont/geosparql#wktLiteral" datatype-uri) - (search "https://www.opengis.net/" string-value)) - (let ((new-quad (quad:copy quad)) - (new-string (cl-ppcre:regex-replace "https://" string-value "http://"))) - (setf (quad:object new-quad) - (sparql-manipulation:make-rdfliteral new-string :datatype-match datatype-match)) - (quad-transformations:update new-quad)) - (quad-transformations:keep)))) - - (format t "~&Joll can write a book title with the right URI and no type.~%") - - (server:execute-query-for-context - "PREFIX foaf: + (sparql-manipulation:string-literal-string + (first (sparql-parser:match-submatches object)))))) + (if (and datatype-uri + (string= "http://www.opengis.net/ont/geosparql#wktLiteral" datatype-uri) + (search "https://www.opengis.net/" string-value)) + (let ((new-quad (quad:copy quad)) + (new-string (cl-ppcre:regex-replace "https://" string-value "http://"))) + (setf (quad:object new-quad) + (sparql-manipulation:make-rdfliteral new-string :datatype-match datatype-match)) + (quad-transformations:update new-quad)) + (quad-transformations:keep)))) + + (format t "~&Joll can write a book title with the right URI and no type.~%") + + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -422,10 +458,10 @@ this point and likely a redpencil image too.") schema:name \"On Types\". }") - (format t "~&Effective changes contain only the data that was actually changed, which is:~%- insert \"On types too.\"~%- delete \"On types too.\"~%") + (format t "~&Effective changes contain only the data that was actually changed, which is:~%- insert \"On types too.\"~%- delete \"On types too.\"~%") - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -436,9 +472,9 @@ this point and likely a redpencil image too.") schema:name \"On Types\", \"On Types Too\". }") - (let ((support:*string-max-size* 50)) - (server:execute-query-for-context - "PREFIX foaf: + (let ((support:*string-max-size* 50)) + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -449,13 +485,13 @@ this point and likely a redpencil image too.") ext:longContent \"This is a string which has more than 50 characters in length\", \"String < 50 chars\" . }") - (format t "~&Matches yield following content for long content: ~%~A" - (server:execute-query-for-context - "PREFIX ext: + (format t "~&Matches yield following content for long content: ~%~A" + (server:execute-query-for-context + "PREFIX ext: SELECT ?content WHERE { ext:longContent ?content }")) - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -466,8 +502,8 @@ this point and likely a redpencil image too.") ext:longContent \"This is a string which has more than 50 characters in length\", \"String < 50 chars\" . }")) - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -482,10 +518,10 @@ this point and likely a redpencil image too.") schema:name ?title. }") - ;; we can delete the types + ;; we can delete the types - (server:execute-query-for-context - "PREFIX foaf: + (server:execute-query-for-context + "PREFIX foaf: PREFIX schema: PREFIX authors: PREFIX books: @@ -496,21 +532,21 @@ this point and likely a redpencil image too.") schema:name \"On Types\". }") - ;; we can have an empty construct where + ;; we can have an empty construct where - (server:execute-query-for-context - "CONSTRUCT { } WHERE { }") + (server:execute-query-for-context + "CONSTRUCT { } WHERE { }") - ;; inserting the UUID with xsd:string will just insert the UUID (configured above) + ;; inserting the UUID with xsd:string will just insert the UUID (configured above) - (server:execute-query-for-context - "PREFIX xsd: + (server:execute-query-for-context + "PREFIX xsd: PREFIX mu: INSERT DATA { mu:uuid \"123\"^^xsd:string. }") - (when *run-geosparql-tests* - (server:execute-query-for-context - "PREFIX xsd: + (when *run-geosparql-tests* + (server:execute-query-for-context + "PREFIX xsd: PREFIX ext: PREFIX mu: PREFIX geo: @@ -520,62 +556,58 @@ this point and likely a redpencil image too.") geo:asWKT \" POINT (155822.2 132723.18)\"^^. }"))) - (with-impersonation-for :jack - ;; can insert some random content - (server:execute-query-for-context - "PREFIX ext: + (with-impersonation-for :jack + ;; can insert some random content + (server:execute-query-for-context + "PREFIX ext: INSERT DATA { ext:myDisplay a ext:NoNameOrLabel; ext:score 9001; ext:level 12. }") - ;; can't insert name or label - (block :no-error - (handler-case - (server:execute-query-for-context - "PREFIX ext: + ;; can't insert name or label + (block :no-error + (handler-case + (server:execute-query-for-context + "PREFIX ext: INSERT DATA { ext:myDisplay ext:name \"Failing name\". }") - (handle-update-unit:unwritten-data-error (e) - (format t "Received expected error ~A" e) - (return-from :no-error t))) - (error 'simple-error :format-control "Expected triples not being written, but received no error.")) - (block :no-error - (handler-case - (server:execute-query-for-context - "PREFIX ext: + (handle-update-unit:unwritten-data-error (e) + (format t "Received expected error ~A" e) + (return-from :no-error t))) + (error 'simple-error :format-control "Expected triples not being written, but received no error.")) + (block :no-error + (handler-case + (server:execute-query-for-context + "PREFIX ext: INSERT DATA { ext:myDisplay ext:label \"Failing label\". }") - (handle-update-unit:unwritten-data-error (e) - (format t "Received expected error ~A" e) - (return-from :no-error t))) - (error 'simple-error :format-control "Expected triples not being written, but received no error.")) - (server:execute-query-for-context - "PREFIX ext: + (handle-update-unit:unwritten-data-error (e) + (format t "Received expected error ~A" e) + (return-from :no-error t))) + (error 'simple-error :format-control "Expected triples not being written, but received no error.")) + (server:execute-query-for-context + "PREFIX ext: INSERT DATA { ext:myDisplay ext:anotherThing \"Another thing\". }")) - ;; jack can delete (which should use CONSTRUCT) - (with-impersonation-for :jack - (server:execute-query-for-context - "PREFIX ext: + ;; jack can delete (which should use CONSTRUCT) + (with-impersonation-for :jack + (server:execute-query-for-context + "PREFIX ext: DELETE { ext:myDisplay ext:score ?score; ext:level ?level. } WHERE { ext:myDisplay a ext:NoNameOrLabel; ext:score ?score; ext:level ?level. - }")))) + }"))) -(defun run-delta-only-assertion-tests () - "Tests whether we can use graphs which only have emit data through delta-notifier but not through sparql" - ;; TODO: it would be good if this test would also verify data is effectively creating delta messages but that's not - ;; the case yet. - (with-acl-config - (client:query (coerce +(defun delta-only-assertion-tests () + (client:query (coerce "DELETE { GRAPH ?g { ?s ?p ?o } } WHERE { @@ -604,4 +636,41 @@ this point and likely a redpencil image too.") SELECT * WHERE { ?thing a push:Update. }")) - "results" "bindings"))))))) + "results" "bindings")))))) + +(defun run-assertion-tests-with-acl () + "Run the `assertion-tests' with an ACL configuration." + (format t "~%~% Running assertion tests with ACL config") + (clean-up-graphs) + (store-initial-session-data) + + (with-acl-config (assertion-tests))) + +(defun run-assertion-tests-with-odrl () + "Run the `assertion-tests' with an ODRL configuration." + (format t "~%~% Running assertion tests with ODRL config") + (clean-up-graphs) + (store-initial-session-data) + + (with-odrl-config (assertion-tests))) + +(defun run-assertion-tests () + (run-assertion-tests-with-acl) + (run-assertion-tests-with-odrl)) + +(defun run-delta-only-assertion-tests-acl () + (format t "~%~% Running delta only assertion tests with ACL config") + (with-acl-config (delta-only-assertion-tests))) + +;; TODO: This test currently fails since ODRL policies do not yet support the extra options that can +;; be passed to graph specifications. +(defun run-delta-only-assertion-tests-odrl () + (format t "~%~% Running delta only assertion tests with ODRL config") + (with-odrl-config (delta-only-assertion-tests))) + +(defun run-delta-only-assertion-tests () + "Tests whether we can use graphs which only have emit data through delta-notifier but not through sparql" + ;; TODO: it would be good if this test would also verify data is effectively creating delta messages but that's not + ;; the case yet. + (run-delta-only-assertion-tests-acl) + (run-delta-only-assertion-tests-odrl))