diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..0ca0e5b --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "dependencies/cl-ttl-parser"] + path = dependencies/cl-ttl-parser + url = https://github.com/lblod/cl-ttl-parser.git diff --git a/README.md b/README.md index 1827a9d..984bffb 100644 --- a/README.md +++ b/README.md @@ -396,6 +396,429 @@ 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 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 a [Turtle](https://www.w3.org/TR/turtle) file mounted in `./config/authorization/config.ttl`. The following snippet contains the ODRL equivalent, encoded in Turtle format, for the lisp access rights as shown in the [first](#how-to-add-the-sparql-parser-service-to-your-application) in this README. The following subsections describe each part in more detail. Furthermore, a more comprehensive policy example can be found in the [test configuration]('./test/example-config.ttl'). + +```ttl +@prefix example: . +@prefix ext: . +@prefix odrl: . +@prefix sh: . +@prefix vcard: . + +example:examplePolicy a odrl:Set ; + odrl:permission ext:publicRead . + +example:publicGraph a odrl:AssetCollection ; + vcard:fn "public" ; + ext:graphPrefix . + +example:genericAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:publicGraph ; + sh:targetClass ext:all . + +example:publicParty a odrl:PartyCollection ; + vcard:fn "public" . + +example:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target ext:publicGraph ; + odrl:assignee ext:publicParty . +``` + + +The following functionality is *not* yet supported when using an ODRL policy: +- 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. + +Furthermore, [policy rule composition](https://www.w3.org/TR/odrl-model/#composition) is *not* yet supported. So each rule should be specified using its normative cardinalities for property relationships. + + +#### Define a group for users with a certain role in ODRL +An access control policy typically grants different rights to users based on some criteria. For example, an authenticated user may read and edit certain data, whereas other users are only allowed to read data. This requires that we can determine to which group(s) the user performing a request belongs to. In an ODRL configuration this captured by defining a party collection resource. Such a resource should at least have a `vcard:fn` property that specifies the name of the group. The `ext:definedBy` property allows to specify a SPARQL query with which to determine whether a user belongs to a group. More specifically, the provided query should return a match when a user belongs to the defined group. + +Say you want to define a group that contains all authenticated users. In a semantic.works application this usually means that there exists a session associated with an account, indicating that the user previously logged in. The following snippet defines a party collection for group named `authenticated` where membership is determined by the existence of a session associated with an account: + +```ttl +@prefix example: . +@prefix ext: . +@prefix odrl: . +@prefix vcard: . + +example:authenticatedUserParty a odrl:PartyCollection ; + vcard:fn "authenticated" ; + ext:definedBy """PREFIX session: + + SELECT DISTINCT ?account WHERE { + session:account ?account. + }""" . +``` + +Note that the constant `SESSION_ID` is a placeholder and will be automatically replaced by the actual session identifier found in the request when the query is executed. + +#### Define which triples are accessible for a graph in ODRL +Typically you want to explicitly specify which (kind of) triples within a graph an access control rule can be applied to. In an ODRL configuration such information is captured by an Asset collection along with its contained assets. + +For instance, say you have a graph `http://mu.semte.ch/graphs/people` containing triples for resources of types `foaf:Person` and `foaf:OnlineAccount`. The following snippet defines an asset collection `example:peopleGraph`. The `vcard:fn` property specifies the name for this asset collection. This name should be unique as it will be used internally to identify this asset collection. The `ext:graphPrefix` property has as value the URI of the graph the asset collection refers to. + +```ttl +@prefix example: . +@prefix ext: . +@prefix foaf: . +@prefix odrl: . +@prefix sh: . +@prefix vcard: . + + +example:peopleGraph a odrl:AssetCollection ; + vcard:fn "people" ; + ext:graphPrefix . + +example:foafPersonAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person . + +example:foafOnlineAccountAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:OnlineAccount . +``` + +The two assets `example:foafPersonAsset` and `example:foafOnlineAccountAsset` specify the relevant triples in a graph. The `odrl:PartOf` property specifies which asset collection(s) the asset belongs to. Note, that these assets are also assigned the type `sh:NodeShape`. This is because we use [SHACL](https://www.w3.org/TR/shacl/) shapes the define exact triples covered by an asset. The simplest case is to specify a resource type as value of the `sh:targetClass` property. This means that the asset covers all triples with a subject resource of the specified type. More concretely, for the `example:foafPersonAsset` this means that asset covers all triples whose subject is a resource of type `foaf:Person`. Keep in mind that the triples for an asset should always be considered with respect to the asset collection(s) it is part of. More concretely, the above `example:foafOnlineAccountAsset` only covers triples in the graph the corresponds to the `example:peopleGraph` it is part of. + +If you are interested in a more limited set of triples, you can explicitly specify one or more predicates using SHACL property shapes. This can be achieved by defining the appropriate values for `sh:property` properties. For example, say you only want to cover triples for `foaf:Person` resources that have as predicate `foaf:firstName` or `foaf:familyName`. In that case you can specify two property nodes, one for each predicate, as shown for `example:foafPersonAssetOnlyName` below. + +```ttl +@prefix example: . +@prefix foaf: . +@prefix odrl: . +@prefix sh: . + +example:foafPersonNamesOnlyAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person ; + sh:property [ sh:path foaf:firstName ] , + [ sh:path foaf:familyName ] . +``` + +Alternatively, you may be interested in most triples for a resource type except those with a few specific predicates. While you can list all relevant predicates as above, sparql-parser supports a shorter notation to describe such situations more concisely. Similar to above this uses SHACL property shapes to specify the desired predicates, but surrounding them with a `sh:not` logical constraint component. For example, say you are interested in all triples with a `foaf:OnlineAccount` resource as subject, except those triples that have as predicate `ext:password` or `account:accountName`. This can be specified as shown in the `example:foafOnlineAccountAsset` shown below. + +```ttl +@prefix example: +@prefix ext: . +@prefix foaf: . +@prefix odrl: . +@prefix sh: . + +example:foafOnlineAccountAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:OnlineAccount ; + sh:not [ + sh:property [ sh:path ext:password ], + [ sh:path foaf:accountName ] + ] . +``` + +So far the assets only concerned triples with a *subject* of a specific resource type. To specify triples where the *object* is of a given resource type you can use property shapes with an `sh:inversePath` as property path. For example, the `example:foafPersonObjectAsset` below covers all triples which have an object of type `foaf:Person`. Here the `ext:all` object acts as a wildcard value meaning all predicates. + +```ttl +@prefix example: . +@prefix ext: . +@prefix foaf: . +@prefix odrl: . +@prefix sh: . + +example:foafPersonObjectAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person ; + sh:property [ + sh:path [ sh:inversePath ext:all ] + ] . +``` + +Similarly as before, you can also specify a concrete predicate for an inverse path to limit an asset to triples with an object of a certain *and* specific predicates. For example, the `example:foafPersonObjectEmployeeAsset` below covers triples that have a `foaf:Person` as object and have `schema:employee` as predicate. + +```ttl +@prefix example: . +@prefix foaf: . +@prefix odrl: . +@prefix schema: . +@prefix sh: . + +example:foafPersonObjectEmployeeAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person ; + sh:property [ + sh:path [ sh:inversePath schema:employee ] + ] . +``` + +Note that you can combine regular and inverted paths in a single asset. For example, the `example:foafPersonComplexAsset` below covers all triples that have + +- as *subject* a resource of type `foaf:Person` AND as *predicate* `foaf:firstName` or `foaf:familyName`; OR +- as *object* a resource of type `foaf:Person` AND as *predicate* `schema:employee` + +```ttl +@prefix example: . +@prefix foaf: . +@prefix odrl: . +@prefix schema: . +@prefix sh: . + +example:foafPersonComplexAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person ; + sh:property [ sh:path foaf:firstName ] , + [ sh:path foaf:familyName ] , + [ sh:path [ sh:inversePath schema:employee ] ] . +``` + + +#### Granting a group rights to a graph in ODRL +Once you have defined the necessary [party collections](#define-a-group-for-users-with-a-certain-role-in-odrl) and [asset collections](#define-which-triples-are-accessible-for-a-graph-in-odrl) you can grant rights by defining ODRL permissions. Each permission requires you define exactly one action, target asset collection, and assignee party collection. For example, the `example:peopleReadPermission` below grants users that are members of the `example:authenticatedUserParty` party collection read rights to the triples in the `example:peopleGraph` asset collection. + +```ttl +@prefix example: . +@prefix odrl: . + +example:peopleReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . +``` + +> [!IMPORTANT] +> Sparql-parser only supports the `odrl:read` and `odrl:modify` actions, specifying any other action will result in an error on loading the defined policy. + +To grant multiple rights you have to specify multiple permissions, one for each allowed action. For instance, to grant members of the `example:authenticatedUserParty` party collection also write rights to the triples in the `example:peopleGraph` asset collection you have add a second permission as shown below. + +```ttl +@prefix example: . +@prefix odrl: . + +example:peopleReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . + +example:peopleWritePermission a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . +``` + +Similarly, grant members of a party collection rights to multiple asset collections requires you specify one permission per target asset collection. For example, the following snippet grants members of the `example:authenticatedUserParty` party collection read rights to the `example:peopleGraph` asset collection as well as the `example:organizationGraph` asset collection. + +```ttl +@prefix example: . +@prefix odrl: . + +example:peopleReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . + +example:organizationReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:organizationGraph ; + odrl:assignee example:authenticatedUserParty . +``` + +#### Define access rights for a set of similar graphs in ODRL +Your application may have multiple graphs whose contents are structurally similar in that they overlap in terms of resource types and predicates. For example, your application might have a single graph per organization where each graph contains similar triples such as the organization's name, address and employees. + +For such situations sparql-parser supports defining the access rights only once for all graphs together, instead of having to define them individually for each graph and group separately. First this requires specifying one or more values for an `ext:queryParameters` property for a party collection. Note, that the literal(s) assigned as object value(s) must be a subset of the variables specified in the `SELECT` clause of the query specified in the `ext:definedBy` property. + +```ttl +@prefix example: . +@prefix ext: . +@prefix odrl: . +@prefix vcard: . + +example:organizationMemberParty a odrl:PartyCollection ; + vcard:fn "organization-member" ; + ext:queryParameters "session_group" ; + ext:definedBy """PREFIX ext: + PREFIX mu: + SELECT ?session_group ?session_role WHERE { + ext:sessionGroup/mu:uuid ?session_group. + }""" . +``` + +Let's assume that the graphs for the different organizations have URIs for the form `http://mu.semte.ch/graphs/organizations/UUID`, where UUID identifies the specific organization this graph pertains to. The following asset collection would cover all such graphs. Note that the provided graph URI specified as value for `ext:graphPrefix` ends with a "/" and does **not** contain the UUID part. (For brevity we do not specify any assets in this example.) + +```ttl +example:organizationGraphs a odrl:AssetCollection ; + vcard:fn "organization" ; + ext:graphPrefix . +``` + +To grant read access to members of the `example:organizationMemberParty` party collection to the `example:organizationGraphs` asset collection the following permission can be defined. + +```ttl +@prefix example: . +@prefix odrl: . + +example:organizationReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:organizationGraphs ; + odrl:assignee example:organizationMemberParty . +``` + +The "magic" here happens when sparql-parser processes an appropriate request, i.e. a request from a member of `example:organizationMemberParty` party collection for triples in the `example:organizationGraphs` asset collection. In such cases sparql-parser determines the target graphs by appending the match(es) for the `session_group` parameter to the graph URI in the `example:organizationGraphs` asset collection. For example, say the query in `example:organizationMemberParty` returns two matches for `session_group`: `someOrganization` and `aCompletelyDifferentOrganization`. The incoming request will then be forward to two graphs with as URIs: + +- `http://mu.semte.ch/graphs/organizations/someOrganization` +- `http://mu.semte.ch/graphs/organizations/aCompletelyDifferentOrganization` + +If you want to specify multiple values for the `ext:queryParamters` you have to specify them as elements in a Turtle collection. The matches will be appended to graph URIs in the same order as the elements in the collection. For example, you can add `session_role` as a second `ext:queryParameters` argument to the above `example:organizationMemberParty` party collection as follows: + +```ttl +@prefix example: . +@prefix ext: . +@prefix odrl: . +@prefix vcard: . + +example:organizationMemberParty a odrl:PartyCollection ; + vcard:fn "organization-member" ; + ext:queryParameters ( "session_group" "session_role" ); + ext:definedBy """PREFIX ext: + PREFIX mu: + SELECT ?session_group ?session_role WHERE { + ext:sessionGroup/mu:uuid ?session_group. + }""" . +``` + +Let's say that the party collection's query returns the following matches for your application: + +| session_group | session_role | +|----------------------------------|---------------------------| +| someOrganization | someRole | +| aCompletelyDifferentOrganization | aCompletetlyDifferentRole | + +In this case sparql-sparser will use the following graph URIs to forward requests for the `example:organizationGraphs` asset collection: + +- `http://mu.semte.ch/graphs/organizations/someOrganization/someRole` +- `http://mu.semte.ch/graphs/organizations/aCompletelyDifferentOrganization/aCompletetlyDifferentRole` + + +#### Generating delta messages for data changes in ODRL +This functionality is not part of the ODRL policy itself. This should be configured in the `config.lisp` file as explained in [this guide](#generating-delta-messages-for-data-changes). + +> [!WARNING] +> Policies in ODRL do not support enabling delta messages only for specific asset collections. + +#### Enable additional logging in ODRL +This functionality is not part of the ODRL policy itself. This should be configured in the `config.lisp` file as explained in [this guide](#enable-additional-logging). + +#### Define access rights for specific services in ODRL +It is likely that in your semantic.works application not all requests sent to the SPARQL endpoint are (indirectly) triggered by users with a session. For example, a service may periodically and autonomously retrieve triples from the endpoint. In such cases, requests are not associated with a session from which the appropriate access-groups can be determined. Sparql-parser supports *scopes** which facilitate defining access control rules for such scenarios. + +**NOTE**: This requires the service to which rights are granted is created with [mu-javascript-template](https://github.com/mu-semtech/mu-javascript-template) v1.9.0 or newer. Services based on older templates should first be upgraded or can use [mu-auth-sudo](https://github.com/lblod/mu-auth-sudo) as alternative solution. + +For instance, let's assume your application has the following access control policy: + +```ttl +@prefix example: . +@prefix ext: . +@prefix odrl: . +@prefix vcard: . + +example:authenticatedUserParty a odrl:PartyCollection ; + vcard:fn "authenticated" ; + ext:definedBy """PREFIX session: + + SELECT DISTINCT ?account WHERE { + session:account ?account. + }""" . + +example:peopleGraph a odrl:AssetCollection ; + vcard:fn "people" ; + ext:graphPrefix . + +example:foafPersonAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:Person . + +example:foafOnlineAccountAsset a odrl:Asset, sh:NodeShape ; + odrl:partOf example:peopleGraph ; + sh:targetClass foaf:OnlineAccount . + +example:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . + +example:publicWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty . +``` + +Now say you have a service `peopleservice` in your application which requires periodically retrieve the names of the `foaf:Person`s in the `people` graph. In your `docker-compose.yml` entry for this service, specify a value for the `DEFAULT_MU_AUTH_SCOPE` environment variable. The `peopleservice` will supply this value in the header of each outgoing request. + +```yaml +services: + peopleservice: + image: example/peopleservice:0.0.1 + environment: + DEFAULT_MU_AUTH_SCOPE: "http://services.semantic.works/people-service" +``` + +In your sparql-parser configuration you can use the `ext:scope` predicate to specify a scope for a permission. For instance, the following snippet essentially states that the permissions are applicable for requests with the scope `"http://services.semantic.works/people-service"`. + +```ttl +example:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty ; + ext:scope "http://services.semantic.works/people-service" . + +example:publicWrite a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty ; + ext:scope "http://services.semantic.works/people-service" . +``` + +It is possible to specify multiple scopes for a single permission. In this case a permission will be applicable if a request specifies one of the scopes in its header. For example, the following snippet apply to requests that specify as scope header either `"http://services.semantic.works/people-service"` or `"http://services.semantic.works/another-service"`. + +```ttl +example:publicRead a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:peopleGraph ; + odrl:assignee example:authenticatedUserParty ; + ext:scope "http://services.semantic.works/people-service" , + "http://services.semantic.works/another-service" +``` + ## Reference ### ACL configuration interface #### `define-graph` diff --git a/dependencies/cl-ttl-parser b/dependencies/cl-ttl-parser new file mode 160000 index 0000000..4478e63 --- /dev/null +++ b/dependencies/cl-ttl-parser @@ -0,0 +1 @@ +Subproject commit 4478e637b699e87280a8a7094795336b3c4f371c diff --git a/launch-sparql-parser.sh b/launch-sparql-parser.sh index 94a9399..bf4c235 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,ttl} /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..59a43d8 --- /dev/null +++ b/odrl/odrl.lisp @@ -0,0 +1,290 @@ +(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. + +(defparameter supported-odrl-actions + '("http://www.w3.org/ns/odrl/2/read" + "http://www.w3.org/ns/odrl/2/modify" + "http://www.w3.org/ns/odrl/2/write") + "The absolute URIs of the ODRL actions we support in policies.") + +(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.")) + +;; NOTE (08/04/2026): We use to `initialize-instance' to check arguments instead of `:initform' to +;; allow more precise checks. For example, passing on `nil' as rules will result in unexpected +;; behaviour. +(defmethod initialize-instance :after ((policy policy) &key) + (with-slots (rules) policy + (unless (and rules (> (length rules) 0)) + (error "Must supply at least one RULE in a policy.")))) + +(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) + (with-slots (name) concept + (unless name + (error "Must supply a NAME for a party collection.")) + + (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) + (with-slots (name graph assets) concept + (unless name + (error "Must supply a NAME for an asset collection.")) + (unless graph + (error "Must supply a GRAPH (PREFIX) for an asset collection.")) + (unless (and assets (> (length assets) 0)) + (error "Must supply at least one ASSET that is part of an asset collection")) + + (setf 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 + (scopes :initarg :scopes + :type list + :reader scopes)) + (: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.")) + +(defmethod initialize-instance :after ((concept rule) &key) + (with-slots (actions) concept + (unless (and actions (> (length actions) 0)) + (error "Must supply at least one ACTION for a rule.")))) + +(defclass permission (rule) + () + (:documentation "An ODRL permission represents that an assignee is allowed to perform an action on a target.")) + +(defmethod initialize-instance :after ((concept permission) &key) + (with-slots (actions target assignee) concept + (unless (and actions (> (length actions) 0)) + (error "Must supply at least one ACTION for a permission.")) + (unless target + (error "Must supply a TARGET asset collection for a permission.")) + (unless assignee + (error "Must supply an ASSIGNEE party collection for a permission.")))) + +(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.")) + +;; NOTE (08/04/2026): This is NOT equality of rules as it does not take into account actions. +(defun rules-match-p (left right) + "Return t if the rules LEFT and RIGHT have the same target, assignee, and set of scopes." + (and (eq (slot-value left 'assignee) (slot-value right 'assignee)) + (eq (slot-value left 'target) (slot-value right 'target)) + ;; set equality for scopes slots + (let ((lscopes (slot-value left 'scopes)) + (rscopes (slot-value right 'scopes))) + (and + (null (set-difference lscopes rscopes :test #'string=)) + (null (set-difference rscopes lscopes :test #'string=)))))) + +(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 scopes) concept + (acl:grant* + :scopes (or scopes (list 'acl:_)) + :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 "Encountered a unsupported action \"~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) + (with-slots (uri actions target assignee scopes) object + (format + stream + "~a ~a~&~2t~&~2t~&~2t~&~2t" + (type-of object) + uri + actions + (uri target) + (uri assignee) + scopes)))) + +(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-ttl.lisp b/odrl/parse-ttl.lisp new file mode 100644 index 0000000..d08773d --- /dev/null +++ b/odrl/parse-ttl.lisp @@ -0,0 +1,361 @@ +(in-package :odrl-config) + +(defun policy-file (&optional filename) + "Get the path to the file to read the ODRL policy from. + +If FILENAME is nil, fall back to \"config\" as default filename for the policy file." + (if (find :docker *features*) + (concatenate 'string "../config/" (or filename "config") ".ttl") + "test/example-config.ttl")) + +(defun read-policy-file (path) + "Read the policy file at PATH 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) + (cl-ttl-parser:parse-ttl (read-policy-file path))) + (error (e) + (format t "~& >> WARN: An error occurred when trying to read the configuration file: ~% >>>> '~A'~%" e)))) + +;; +;; Utilities to process policy graph +;; +(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" + ;; TODO: Use proper predicate + :ext-scope "http://mu.semte.ch/vocabularies/ext/scope" + :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-first "http://www.w3.org/1999/02/22-rdf-syntax-ns#first" + :rdf-rest "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest" + :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 the full uri for the predicate matching INDICATOR as a string." + (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" + ;; NOTE (27/03/2026): Not actually a resource type + :rdfs-nil "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil") + "A plist containing the full uris for the resources types used in ODRL policies.") + +(defun type-uri (indicator) + "Return the full uri for the resource type matching INDICATOR as a string." + (getf resource-types-plist indicator)) + +(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 object of TRIPLE." + (third triple)) + +(defun uri-string (uri) + "Return the string representing URI." + (if (quri:uri-p uri) + (quri:render-uri uri) + uri)) + +(defun uri-equal-p (left right) + "Check whether LEFT and RIGHT identify the same resource." + (cond + ((and (quri:uri-p left) (quri:uri-p right)) (quri:uri-equal left right)) + ((and (cl-ttl-parser:blank-node-p left) (cl-ttl-parser:blank-node-p right)) + (equal left right)) ; consider blank nodes equal if they have the same label + ;; NOTE (27/03/2026): Needed because we do not pass quri:uri to ODRL but their strings + ((and (quri:uri-p left) (stringp right)) (string= (uri-string left) right)) + ((and (stringp left) (quri:uri-p right)) (string= left (uri-string right))) + (t nil))) + +(defun filter-subject (resource graph) + "Keep only triples in GRAPH that have RESOURCE as subject." + (remove-if-not + (lambda (triple) (uri-equal-p resource (triple-subject triple))) + graph)) + +(defun filter-predicate (predicate graph) + "Return all triples in GRAPH that have PREDICATE as predicate value." + (remove-if-not + (lambda (triple) (uri-equal-p predicate (triple-predicate triple))) + graph)) + +(defun filter-subject-predicate (resource predicate graph) + "Return all triples in GRAPH that have RESOURCE as subject and PREDICATE as predicate." + (remove-if-not + (lambda (triple) + (and (uri-equal-p resource (triple-subject triple)) + (uri-equal-p predicate (triple-predicate triple)))) + graph)) + +(defun filter-predicate-object (predicate object graph) + "Return all triple objects in GRAPH that have PREDICATE as predicate and OBJECT as object." + (remove-if-not + (lambda (triple) + (and (uri-equal-p predicate (triple-predicate triple)) + (or (uri-equal-p object (triple-object triple)) + (equal object (triple-object triple))))) + graph)) + +(defun list-parts-of-collection (uri graph) + "Return a list of the uris of all resources that are a part of the collection resource URI in GRAPH." + (let ((parts (filter-predicate-object (predicate-uri :odrl-part-of) uri graph))) + (mapcar #'triple-subject parts))) + +(defun filter-resources-for-type (type graph) + "Filter the type triples for resources of TYPE in GRAPH." + (remove-if-not + (lambda (triple) (uri-equal-p type (triple-object triple))) + (filter-predicate (predicate-uri :rdf-type) graph))) + +(defun list-resource-uris (type graph) + "Return a list containing the uri of each resource of TYPE in GRAPH." + (mapcar #'triple-subject (filter-resources-for-type type graph))) + +(defun list-assets (graph) + "List the uris for ODRL asset resources in GRAPH." + (list-resource-uris (type-uri :odrl-asset) graph)) + +(defun list-permissions-in-policy (graph) + "Return a list of the uris of all permissions in the policy defined by GRAPH." + (mapcar + (lambda (triple) (triple-object triple)) + (filter-predicate (predicate-uri :odrl-permission) graph))) + +(defun list-asset-collections (graph) + "List the uris for ODRL asset collection resources in GRAPH." + (list-resource-uris (type-uri :odrl-asset-collection) graph)) + +(defun list-party-collections (graph) + "List the uris for ODRL party collection resources in GRAPH." + (list-resource-uris (type-uri :odrl-party-collection) graph)) + +(defun find-policy-uri (graph) + "Find the uri for the policy resource defined in GRAPH." + (car (list-resource-uris (type-uri :odrl-set) graph))) + +(defun rdf-literal-value-maybe (literal) + "Return the value of LITERLAL if it is an rdf literal object." + (when (cl-ttl-parser:rdf-literal-p literal) + (cl-ttl-parser:rdf-literal-value literal))) + +;; NOTE (01/10/2025): These macros are used to make the init-forms in the `let' operators in the +;; conversion functions more readable. +(defmacro first-value-for-predicate (predicate graph) + "Return the value of the first object for PREDICATE encountered in GRAPH." + `(triple-object (car (filter-predicate ,predicate ,graph)))) + +(defmacro first-triple-for-resource (uri graph) + "Return the first triple with URI as subject in GRAPH." + `(car (filter-subject ,uri ,graph))) + +;; +;; Conversion to ODRL +;; +(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) (uri-equal-p (slot-value shape 'uri) uri)) + shapes))) + +(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) (uri-equal-p (slot-value concept 'uri) uri)) + concepts))) + +(defun make-rule-set (graph) + "Make a `rule-set' instance for the policy described by GRAPH." + (let ((asset-collections (make-asset-collections graph)) + (party-collections (make-party-collections graph)) + (permissions (list-permissions-in-policy graph))) + (make-instance + 'rule-set + :uri (find-policy-uri graph) + :rules (mapcar + (lambda (permission) + (make-permission permission asset-collections party-collections graph)) + permissions)))) + +;; Party collections +(defun make-party-collections (graph) + "Make an `party-collection' for each party collection resource in GRAPH." + (mapcar + (lambda (uri) (make-party-collection uri graph)) + (list-party-collections graph))) + +(defun collect-rdf-list (uri graph) + "Collect all elements in the rdf list starting with element URI. + +Return nil if URI does not identify an rdf list element in GRAPH." + (alexandria:when-let ((first (car (filter-subject-predicate uri (predicate-uri :rdf-first) graph))) + (rest (car (filter-subject-predicate uri (predicate-uri :rdf-rest) graph)))) + (append (list (triple-object first)) + (unless (uri-equal-p (triple-object rest) (type-uri :rdfs-nil)) + (collect-rdf-list (triple-object rest) graph))))) + +(defun make-party-collection (uri graph) + "Make a `party-collection' instance for the resource with URI." + (flet ((parse-parameters (parameters) + (if (cl-ttl-parser:blank-node-p parameters) + ;; queryParameters was a collection, converted to an RDF list. `parameters' is the + ;; blank node that contains the first element of the RDF list. + (mapcar + (lambda (elem) (cl-ttl-parser:rdf-literal-value elem)) + (collect-rdf-list parameters graph)) + ;; queryParameters was a single string, extract the value from the literal it became + (list (cl-ttl-parser:rdf-literal-value parameters))))) + (let* ((triples (filter-subject uri graph)) + (name (first-value-for-predicate (predicate-uri :vcard-fn) triples)) + (description (first-value-for-predicate (predicate-uri :dcterms-description) triples)) + (parameters (first-value-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-string uri) + :name (rdf-literal-value-maybe name) + :description (rdf-literal-value-maybe description) + :parameters (when parameters (parse-parameters 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 (rdf-literal-value-maybe query))))) + +;; Asset Collections and Assets (Node shapes) +(defun make-asset-collections (graph) + "Make an `asset-collection' for each asset collection resource in GRAPH." + (let ((assets (make-node-shapes graph))) + (mapcar + (lambda (uri) (make-asset-collection uri assets graph)) + (list-asset-collections graph)))) + +(defun make-asset-collection (uri assets graph) + "Make an `asset-collection' instance for the resource with URI." + (let* ((triples (filter-subject uri graph)) + (name (first-value-for-predicate (predicate-uri :vcard-fn) triples)) + (description (first-value-for-predicate (predicate-uri :dcterms-description) triples)) + (graph-uri (first-value-for-predicate (predicate-uri :ext-graph-prefix) triples)) + (assets-in-collection (list-parts-of-collection uri graph))) + (make-instance + 'asset-collection + :uri (uri-string uri) + :name (rdf-literal-value-maybe name) + :description (rdf-literal-value-maybe description) + :graph (uri-string graph-uri) + :assets (mapcar + (lambda (uri) (find-shape-with-uri uri assets)) + assets-in-collection)))) + +(defun make-node-shapes (graph) + "Make a `node-shape' instance for each ODRL asset resource in graph." + (mapcar + (lambda (uri) (make-node-shape uri graph)) + (list-assets graph))) + +(defun make-node-shape (uri graph) + "Make a `node-shape' for the resource with URI." + (let* ((triples (filter-subject uri graph)) + (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 (filter-predicate (predicate-uri :sh-not) triples))) + (properties (if not-triple + (filter-subject-predicate + (triple-object not-triple) + (predicate-uri :sh-property) + graph) + (filter-predicate (predicate-uri :sh-property) triples)))) + (make-instance + 'node-shape + :uri (uri-string uri) + :target-class (uri-string target) + :properties (mapcar + (lambda (prop) (make-property-shape prop graph)) + (mapcar #'triple-object properties)) + :notp (when not-triple t)))) + +(defun make-property-shape (uri graph) + "Make a `property-shape' instance for the resource with URI." + (let ((path (triple-object (first-triple-for-resource uri graph)))) + (make-instance + 'property-shape + :uri (uri-string uri) + :path (if (quri:uri-p path) + (uri-string path) + (make-property-path path graph))))) + +(defun make-property-path (uri graph) + "Make a `property-path' instance for the resource with URI." + (let* ((triple (first-triple-for-resource uri graph)) + (path (triple-predicate triple)) + (object (triple-object triple))) + (make-instance + 'property-path + :predicate-path (uri-string path) + :object (uri-string object)))) + +(defun make-permission (uri asset-col party-col graph) + "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 (filter-subject uri graph)) + (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)) + (scopes (filter-predicate (predicate-uri :ext-scope) triples))) + (make-instance + 'permission + :uri (uri-string uri) + :actions (when action (list (make-action action))) + :target target + :assignee assignee + :scopes (mapcar + (lambda (scope) + (cl-ttl-parser:rdf-literal-value (triple-object scope))) + scopes)))) + +(defun make-action (uri) + "Make an `action' instance for the given URI." + (make-instance 'action :uri (uri-string uri))) diff --git a/odrl/shacl.lisp b/odrl/shacl.lisp new file mode 100644 index 0000000..20fe3c8 --- /dev/null +++ b/odrl/shacl.lisp @@ -0,0 +1,130 @@ +(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")) + +(defmethod initialize-instance :after ((node node-shape) &key) + (with-slots (target-class) node + (unless target-class + (error "Must supply a TARGET-CLASS for a node shape.")))) + +(defclass property-shape (shape) + ((path :initarg :path + :reader path)) ; value is a predicate URI or a `property-path' instance + (:documentation "A SHACL property shape")) + +(defmethod initialize-instance :after ((shape property-shape) &key) + (with-slots (path) shape + (unless path + (error "Must supply a PATH for a property.")))) + +(defclass property-path () + ((predicate-path :initarg :predicate-path + :reader predicate-path) + (object :initarg :object + :reader object)) + (:documentation "A SHACL property path.")) + +(defmethod initialize-instance :after ((prop property-path) &key) + (with-slots (predicate-path object) prop + (unless predicate-path + (error "Must supply a PREDICATE PATH for a property path.")) + (unless object + (error "Must supply an OBJECT for a 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..ba64240 100644 --- a/sparql-parser.asd +++ b/sparql-parser.asd @@ -6,7 +6,8 @@ :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) + ;; TODO: Add `cl-ttl-parser' as submodule + :depends-on (alexandria cl-ppcre bordeaux-threads woo dexador jsown luckless sha1 trivial-backtrace flexi-streams cl-ttl-parser) :components ((:file "packages") ;; supporting code (:file "support/support") @@ -37,6 +38,10 @@ (:file "acl/acl") (:file "acl/configuration-interface") (:file "acl/config") + ;; ODRL configuration + (:file "odrl/parse-ttl") + (:file "odrl/odrl") + (:file "odrl/shacl") ;; ;; reasoning to determine graphs ;; (:file "reasoner/tree-mirror") ;; (:file "reasoner/prefixes") @@ -61,4 +66,5 @@ ;; administration (:file "administration/string-files") ;; configuration - (:file "config/config"))) + (:file "config/config") + (:file "odrl/load-config"))) diff --git a/test/example-config.ttl b/test/example-config.ttl new file mode 100644 index 0000000..4db850e --- /dev/null +++ b/test/example-config.ttl @@ -0,0 +1,155 @@ +@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:scopeReadPermission , + example:scopeWritePermission . + +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. + }""" . + +ext:organizationMemberParty a odrl:PartyCollection ; + vcard:fn "organization-member" ; + ext:queryParameters ( "session_group" "session_role" ) ; + ext:definedBy """PREFIX ext: + PREFIX mu: + SELECT ?session_group ?session_role WHERE { + ext:sessionGroup/mu:uuid ?session_group. + }""" . + + +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:personFavoriteAuthorAsset 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:WildCardAsset 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 . + +example:scopeReadPermission a odrl:Permission ; + odrl:action odrl:read ; + odrl:target example:publicGraph ; + odrl:assignee example:publicParty ; + ext:scope "http://services.semantic.works/admin-service" . + +example:scopeWritePermission a odrl:Permission ; + odrl:action odrl:modify ; + odrl:target example:publicGraph ; + odrl:assignee example:publicParty ; + ext:scope "http://services.semantic.works/admin-service" . diff --git a/test/scenario.lisp b/test/scenario.lisp index 2b1b824..b549b2f 100644 --- a/test/scenario.lisp +++ b/test/scenario.lisp @@ -25,6 +25,12 @@ :jane "http://mu.semte.ch/sessions/janeuuid" :joll "http://mu.semte.ch/sessions/adminuuid")) +;;;; Our services are :admin (read and write public-data), and :catalog (read public) +(defparameter *known-service-scopes* + (list + :admin "http://services.semantic.works/admin-service" + :catalog "http://services.semantic.works/catalog-service")) + (defun clean-up-graphs () (client:query (coerce "DELETE { @@ -175,6 +181,54 @@ :to acl::push-updates :for "public") + (acl:grant (acl::read acl::write) + :to-graph acl::public-data + :for-allowed-group "public" + :scopes '("http://services.semantic.works/admin-service")) + + (acl:grant (acl::read) + :to-graph acl::public-data + :for-allowed-group "public" + :scopes '("http://services.semantic.works/catalog-service")) + ,@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) @@ -183,6 +237,12 @@ (:mu-session-id (getf *known-session-ids* ,user)) ,@body)) +(defmacro with-scope-for (service &body body) + "Impersonates SERVICE by setting its scope." + `(server::with-call-context + (:mu-call-scope (getf *known-service-scopes* ,service)) + ,@body)) + (defun store-initial-session-data () "Stores the initial session data in the triplestore." (client:query (coerce @@ -212,17 +272,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 +292,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 +311,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 +325,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 +339,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 +355,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 +370,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 +387,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: @@ -344,11 +401,11 @@ 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 +416,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 +438,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 +479,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 +493,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 +506,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 +523,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 +539,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 +553,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 +577,165 @@ 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 + (format t "~&Admin service can read and write~%") + (with-scope-for :admin + (format t "~&Can add authors.~%") + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + + INSERT DATA { + authors:david-graeber a foaf:Person; + foaf:name \"David Graeber\". + }") + + (format t "~&Can add a book for an author.~%") + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + PREFIX books: + + INSERT DATA { + books:dawn a schema:Book; + schema:name \"The Dawn of Everything\"; + schema:creator authors:david-graeber . + }") + + (format t "~&Can add extra author to book.~%") + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + PREFIX books: + + INSERT DATA { + authors:david-wengrow a foaf:Person ; + schema:name \"David Wengrow\" . + books:dawn schema:creator authors:david-wengrow . + }") + + (format t "~&Cannot add a favorite.~%") + (handler-case + (progn + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + PREFIX books: + PREFIX favorites: + PREFIX ext: + + INSERT DATA { + favorites:me ext:hasBook books:gtd, books:fastAndSlow. + }") + (format t "~&ERROR: Oh noes, Admin service should not be able to add a favorite author!~%")) + (error (e) (declare (ignore e)) t))) + + (format t "~&Catalog service can only read~%") + (with-scope-for :catalog + (format t "~&Cannot add authors.") + (handler-case + (progn + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + + INSERT DATA { + authors:david-graeber a foaf:Person; + foaf:name \"David Graeber\". + }") + (format t "~&ERROR: Oh noes, Catalog service should not be able to add an author!~%")) + (error (e) (declare (ignore e)) t)) + + (format t "~&Cannot add book.~%") + (handler-case + (progn + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + PREFIX books: + + INSERT DATA { + books:dawn a schema:Book; + schema:name \"The Dawn of Everything\"; + schema:creator authors:david-graeber . + }") + (format t "~&ERROR: Oh noes, Catalog service should not be able to add a book!~%")) + (error (e) (declare (ignore e)) t)) + + (format t "~&Cannot add a favorite.~%") + (handler-case + (progn + (server:execute-query-for-context + "PREFIX foaf: + PREFIX schema: + PREFIX authors: + PREFIX books: + PREFIX favorites: + PREFIX ext: + + INSERT DATA { + favorites:me ext:hasBook books:gtd, books:fastAndSlow. + }") + (format t "~&ERROR: Oh noes, Catalog service should not be able to add a favorite author!~%")) + (error (e) (declare (ignore e)) t)))) + +(defun delta-only-assertion-tests () + (client:query (coerce "DELETE { GRAPH ?g { ?s ?p ?o } } WHERE { @@ -604,4 +764,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))