File Coverage

blib/lib/RDF/ACL.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             package RDF::ACL;
2              
3 5     5   135868 use 5.010;
  5         21  
  5         251  
4 5     5   29 use strict;
  5         10  
  5         176  
5 5     5   6040 use utf8;
  5         73  
  5         26  
6              
7 5     5   35006 use Data::UUID;
  5         187767  
  5         397  
8 5     5   245704 use Error qw(:try);
  5         51089  
  5         34  
9 5     5   9590 use RDF::TrineX::Functions -shortcuts;
  0            
  0            
10             use RDF::Query;
11             use RDF::Query::Client;
12             use Scalar::Util qw(blessed);
13             use URI;
14              
15             use constant EXCEPTION => 'Error::Simple';
16             use constant NS_ACL => 'http://www.w3.org/ns/auth/acl#';
17             use constant NS_RDF => 'http://www.w3.org/1999/02/22-rdf-syntax-ns#';
18              
19             our $AUTHORITY = 'cpan:TOBYINK';
20             our $VERSION = '0.104';
21              
22             sub rdf_query
23             {
24             my ($query, $model) = @_;
25             my $class = (blessed($model) and $model->isa('RDF::Trine::Model'))
26             ? 'RDF::Query'
27             : 'RDF::Query::Client';
28             my $results = $class->new($query)->execute($model);
29            
30             if ($results->is_boolean)
31             { return $results->get_boolean }
32             if ($results->is_bindings)
33             { return $results }
34             if ($results->is_graph)
35             { my $m = rdf_parse(); $m->add_hashref($results->as_hashref); return $m }
36            
37             return;
38             }
39              
40             sub new
41             {
42             my $class = shift;
43            
44             my $model = shift;
45             unless (blessed($model) && $model->isa('RDF::Trine::Model'))
46             {
47             $model = rdf_parse($model, @_);
48             }
49            
50             my $self = bless {
51             'model' => $model,
52             'i_am' => undef ,
53             }, $class;
54            
55             return $self;
56             }
57              
58             sub new_remote
59             {
60             my $class = shift;
61             my $ep = shift;
62            
63             my $self = bless {
64             'endpoint' => $ep,
65             }, $class;
66            
67             return $self;
68             }
69              
70             sub check
71             {
72             my ($self, $webid, $item, $level, @datas) = @_;
73              
74             EXCEPTION->throw("Must provide WebID to be checked.")
75             unless defined $webid;
76              
77             EXCEPTION->throw("Must provide item URI to be checked.")
78             unless defined $item;
79              
80             my $model = $self->_union_model(@datas);
81            
82             my $aclvocab = NS_ACL;
83            
84             if (defined $level)
85             {
86             if ($level =~ /^(access|read|write|control|append)$/i)
87             {
88             $level = $aclvocab . (ucfirst lc $level);
89             }
90            
91             my $sparql = <<"SPARQL";
92             PREFIX acl: <$aclvocab>
93             ASK WHERE {
94             {
95             { ?authorisation acl:agentClass ?agentclass . <$webid> a ?agentclass . }
96             UNION { ?authorisation acl:agent <$webid> . }
97             UNION { ?authorisation acl:agentClass <http://xmlns.com/foaf/0.1/Agent> . }
98             }
99             {
100             { ?authorisation acl:accessToClass ?accessclass . <$item> a ?accessclass . }
101             UNION { ?authorisation acl:accessTo <$item> . }
102             UNION { ?authorisation acl:accessToClass <http://www.w3.org/2000/01/rdf-schema#Resource> . }
103             }
104             {
105             ?authorisation acl:mode <$level> .
106             }
107             }
108             SPARQL
109              
110             return rdf_query($sparql, $model);
111             }
112            
113             else
114             {
115             my $sparql = <<"SPARQL";
116             PREFIX acl: <$aclvocab>
117             SELECT DISTINCT ?level
118             WHERE {
119             {
120             { ?authorisation acl:agentClass ?agentclass . <$webid> a ?agentclass . }
121             UNION { ?authorisation acl:agent <$webid> . }
122             UNION { ?authorisation acl:agentClass <http://xmlns.com/foaf/0.1/Agent> . }
123             }
124             {
125             { ?authorisation acl:accessToClass ?accessclass . <$item> a ?accessclass . }
126             UNION { ?authorisation acl:accessTo <$item> . }
127             UNION { ?authorisation acl:accessToClass <http://www.w3.org/2000/01/rdf-schema#Resource> . }
128             }
129             {
130             ?authorisation acl:mode ?level .
131             }
132             }
133             SPARQL
134              
135             my $iterator = rdf_query($sparql, $model);
136             my @rv;
137             while (my $result = $iterator->next)
138             {
139             push @rv, $result->{'level'}->uri
140             if blessed($result->{'level'}) && $result->{'level'}->can('uri');
141             }
142             return @rv;
143             }
144             }
145              
146             sub why
147             {
148             my ($self, $webid, $item, $level, @datas) = @_;
149              
150             EXCEPTION->throw("Must provide WebID to be checked.")
151             unless defined $webid;
152              
153             EXCEPTION->throw("Must provide item URI to be checked.")
154             unless defined $item;
155              
156             EXCEPTION->throw("Must provide item URI to be checked.")
157             unless defined $item;
158              
159             my $model = $self->_union_model(@datas);
160            
161             my $aclvocab = NS_ACL;
162            
163             if ($level =~ /^(access|read|write|control|append)$/i)
164             {
165             $level = $aclvocab . (ucfirst lc $level);
166             }
167            
168             my $sparql = <<"SPARQL";
169             PREFIX acl: <$aclvocab>
170             SELECT DISTINCT ?authorisation
171             WHERE {
172             {
173             { ?authorisation acl:agentClass ?agentclass . <$webid> a ?agentclass . }
174             UNION { ?authorisation acl:agent <$webid> . }
175             UNION { ?authorisation acl:agentClass <http://xmlns.com/foaf/0.1/Agent> . }
176             }
177             {
178             { ?authorisation acl:accessToClass ?accessclass . <$item> a ?accessclass . }
179             UNION { ?authorisation acl:accessTo <$item> . }
180             UNION { ?authorisation acl:accessToClass <http://www.w3.org/2000/01/rdf-schema#Resource> . }
181             }
182             {
183             ?authorisation acl:mode <$level> .
184             }
185             }
186             SPARQL
187              
188             my $iterator = rdf_query($sparql, $model);
189             my @rv;
190             while (my $result = $iterator->next)
191             {
192             if (blessed($result->{'authorisation'}) && $result->{'authorisation'}->can('uri'))
193             {
194             push @rv, $result->{'authorisation'}->uri;
195             }
196             else
197             {
198             push @rv, undef;
199             }
200             }
201             return @rv;
202             }
203              
204             sub allow
205             {
206             my ($self, %args) = @_;
207            
208             EXCEPTION->throw("This ACL is not mutable.")
209             unless $self->is_mutable;
210              
211             EXCEPTION->throw("Must provide an 'item', 'item_class' or 'container' argument.")
212             unless (defined $args{'item'} or defined $args{'item_class'} or defined $args{'container'});
213              
214             EXCEPTION->throw("Cannot provide 'container' with an 'item' or 'item_class' argument.")
215             if ((defined $args{'container'}) and (defined $args{'item'} or defined $args{'item_class'}));
216              
217             $args{'agent_class'} = 'http://xmlns.com/foaf/0.1/Agent'
218             unless (defined $args{'webid'} or defined $args{'agent'} or defined $args{'agent_class'});
219            
220             $args{'level'} = NS_ACL.'Read'
221             unless defined $args{'level'};
222            
223             my $predicate_map = {
224             'level' => NS_ACL . 'mode' ,
225             'item' => NS_ACL . 'accessTo' ,
226             'item_class' => NS_ACL . 'accessToClass' ,
227             'container' => NS_ACL . 'defaultForNew' ,
228             'agent' => NS_ACL . 'agent' ,
229             'agent_class' => NS_ACL . 'agentClass' ,
230             'webid' => NS_ACL . 'agent' ,
231             };
232              
233             my $data = {};
234             my $authid = $self->_uuid;
235            
236             $data->{$authid}->{NS_RDF.'type'} = [
237             { 'type'=>'uri', 'value'=>NS_ACL.'Authorization' },
238             ];
239            
240             foreach my $p (keys %$predicate_map)
241             {
242             next unless defined $args{$p};
243            
244             unless (ref $args{$p} eq 'ARRAY')
245             {
246             $args{$p} = [ $args{$p} ];
247             }
248              
249             foreach my $val (@{$args{$p}})
250             {
251             if (defined $self->who_am_i and $p =~ /^(item|container)$/)
252             {
253             my $control = $self->check($self->who_am_i, $val, 'Control');
254             EXCEPTION->throw("WebID <".$self->who_am_i."> does not have access control for resource <$val>.")
255             unless $control;
256             }
257              
258             if ($p eq 'level' and $val =~ /^(access|read|write|control|append)$/i)
259             {
260             $val = NS_ACL . (ucfirst lc $val);
261             }
262            
263             push @{ $data->{$authid}->{$predicate_map->{$p}} },
264             { 'type'=>'uri', 'value'=>$val };
265             }
266             }
267            
268             $self->model->add_hashref($data);
269            
270             return $authid;
271             }
272              
273             sub deny
274             {
275             my ($self, $id) = @_;
276            
277             EXCEPTION->throw("This ACL is not mutable.")
278             unless $self->is_mutable;
279            
280             if (defined $self->who_am_i)
281             {
282             my $aclvocab = NS_ACL;
283             my $sparql = <<"SPARQL";
284             PREFIX acl: <$aclvocab>
285             SELECT DISTINCT ?resource
286             WHERE
287             {
288             { <$id> acl:accessTo ?resource . }
289             UNION { <$id> acl:accessTo ?resource . }
290             }
291             SPARQL
292             my $iterator = rdf_query($sparql, $self->model);
293             while (my $result = $iterator->next)
294             {
295             next unless $result->{'resource'}->is_resource;
296             next if $self->check($self->who_am_i, $result->{'resource'}->uri, 'Control');
297            
298             EXCEPTION->throw("WebID <".$self->who_am_i."> does not have access control for resource <".$result->{'resource'}->uri.">.");
299             }
300             }
301            
302             my $auth = RDF::Trine::Node::Resource->new($id);
303             my $count = $self->model->count_statements($auth, undef, undef);
304             $self->model->remove_statements($auth, undef, undef);
305             return $count;
306             }
307              
308             sub created
309             {
310             my ($self, $item, $container) = @_;
311            
312             EXCEPTION->throw("This ACL is not mutable.")
313             unless $self->is_mutable;
314            
315             my $aclvocab = NS_ACL;
316             my $graph = rdf_query(<<"QUERY", $self->model);
317             PREFIX acl: <$aclvocab>
318             CONSTRUCT { ?auth ?p ?o . }
319             WHERE {
320             ?auth ?p ?o ;
321             acl:defaultForNew <$container> .
322             FILTER ( sameTerm(?p, acl:mode) || sameTerm(?p, acl:agent) || sameTerm(?p, acl:agentClass) || sameTerm(?p, <http://www.w3.org/1999/02/22-rdf-syntax-ns#type>) )
323             }
324             QUERY
325              
326             my $data = $graph->as_hashref;
327             my $newdata = {};
328             my @rv;
329             foreach my $k (keys %$data)
330             {
331             my $authid = $self->_uuid;
332             $newdata->{$authid} = $data->{$k};
333             $newdata->{$authid}->{$aclvocab.'accessTo'} = [{
334             'type' => 'uri', 'value' => $item
335             }];
336             push @rv, $authid;
337             }
338             $self->model->add_hashref($newdata);
339            
340             return @rv;
341             }
342              
343             sub i_am
344             {
345             my $self = shift;
346             my $old = $self->who_am_i;
347             $self->{'i_am'} = shift;
348             return URI->new($old);
349             }
350              
351             sub who_am_i
352             {
353             my ($self) = @_;
354             return $self->{'i_am'};
355             }
356              
357             sub save
358             {
359             my ($self, $fmt, $file) = @_;
360            
361             EXCEPTION->throw("This ACL is not serialisable.")
362             if $self->is_remote;
363              
364             return rdf_string(
365             $self->model,
366             type => $fmt,
367             output => $file,
368             );
369             }
370              
371             sub is_remote
372             {
373             my ($self) = @_;
374             return defined $self->endpoint;
375             }
376              
377             sub is_mutable
378             {
379             my ($self) = @_;
380             return defined $self->model;
381             }
382              
383             sub model
384             {
385             my ($self) = @_;
386             return $self->{'model'};
387             }
388              
389             sub endpoint
390             {
391             my ($self) = @_;
392             return undef unless defined $self->{'endpoint'};
393             return URI->new(''.$self->{'endpoint'});
394             }
395              
396             # PRIVATE METHODS
397              
398             # * $acl->_uuid
399             #
400             # Returns a unique throwaway URI.
401              
402             sub _uuid
403             {
404             my ($self) = @_;
405            
406             $self->{'uuid_generator'} = Data::UUID->new
407             unless defined $self->{'uuid_generator'};
408            
409             return 'urn:uuid:' . $self->{'uuid_generator'}->create_str;
410             }
411              
412             # * $acl->_union_model(@graphs)
413             #
414             # Creates a temporary model that is the union of the ACL
415             # object's default data source plus additional graphs.
416              
417             sub _union_model
418             {
419             my ($self, @graphs) = @_;
420             my $model;
421            
422             if ($self->is_remote)
423             {
424             $model = $self->endpoint;
425            
426             EXCEPTION->throw("Cannot provide additional data to consider for remote ACL.")
427             if @graphs;
428             }
429             elsif (@graphs)
430             {
431             $model = rdf_parse($self->model, model => RDF::TrineX::Functions::model());
432             foreach my $given (@graphs)
433             {
434             my @given = ref($given) eq 'ARRAY' ? @$given : $given;
435             rdf_parse(@given, model => $model);
436             }
437             }
438             else
439             {
440             $model = $self->model;
441             }
442            
443             return $model;
444             }
445              
446             __PACKAGE__
447             __END__
448              
449             =head1 NAME
450              
451             RDF::ACL - access control lists for the semantic web
452              
453             =head1 SYNOPSIS
454              
455             use RDF::ACL;
456            
457             my $acl = RDF::ACL->new('access.ttl');
458             my $auth = $acl->allow(
459             webid => 'http://example.com/joe#me',
460             item => 'http://example.com/private/document',
461             level => ['Read', 'Write'],
462             );
463             $acl->save('turtle', 'access.ttl');
464            
465             # later...
466            
467             if ($acl->check('http://example.com/joe#me',
468             'http://example.com/private/document',
469             'Read'))
470             {
471             print slurp("private/document");
472             }
473             else
474             {
475             print "Denied";
476             }
477            
478             # later...
479            
480             foreach my $reason ($acl->why('http://example.com/joe#me',
481             'http://example.com/private/document',
482             'Read'))
483             {
484             $acl->deny($reason) if defined $reason;
485             }
486             $acl->save('turtle', 'access.ttl');
487              
488             =head1 DESCRIPTION
489              
490             Note that this module provides access control and does not perform
491             authentication!
492              
493             =head2 Constructors
494              
495             =over 4
496              
497             =item C<< $acl->new($input, %args) >>
498              
499             Creates a new access control list based on RDF data defined in
500             $input. $input can be a serialised string of RDF, a file name,
501             a URI or any other input accepted by the C<parse> function
502             of L<RDF::TrineX::Functions>.
503              
504             C<< new() >> can be called with no arguments to create a
505             fresh, clean ACL containing no authorisations.
506              
507             =item C<< $acl->new_remote($endpoint) >>
508              
509             Creates a new access control list based on RDF data accessed
510             via a remote SPARQL Protocol 1.0 endpoint.
511              
512             =back
513              
514             =head2 Public Methods
515              
516             =over 4
517              
518             =item C<< $acl->check($webid, $item, $level, @data) >>
519              
520             Checks an agent's authorisation to access an item.
521              
522             $webid is the WebID (URI) of the agent requesting access to the item.
523              
524             $item is the URL (URI) of the item being accessed.
525              
526             $level is a URI identifying the type of access required. As special
527             cases, the case-insensitive string 'read' is expanded to the URI
528             E<lt>http://www.w3.org/ns/auth/acl#ReadE<gt>, 'write' to
529             E<lt>http://www.w3.org/ns/auth/acl#WriteE<gt>, 'append' to
530             E<lt>http://www.w3.org/ns/auth/acl#AppendE<gt> and 'control' to
531             E<lt>http://www.w3.org/ns/auth/acl#ControlE<gt>.
532              
533             If the access control list is local (not remote), zero or more
534             additional RDF graphs can be passed (i.e. @data) containing
535             data to take into consideration when checking the agent's authorisation.
536             This data is trusted blindly, so should not include data that the
537             user has themselves supplied. If the access control list is remote,
538             then this method throws an error if any additional data is provided.
539             (A remote ACL cannot take into account local data.)
540              
541             If $level is provided, this method returns a boolean.
542              
543             If $level is undefined or omitted, this method returns a list
544             of URIs which each represent a type of access that the user is
545             authorised.
546              
547             =item C<< $acl->why($webid, $item, $level, @data) >>
548              
549             Investigates an agent's authorisation to access an item.
550              
551             Arguments as per C<< check >>, however $level is required.
552              
553             Returns a list of authorisations that justify a user's access to
554             the item with the given access level. These authorisations are
555             equivalent to $authid values provided by C<< allow() >>.
556              
557             In some cases (especially if the authorisation was created
558             by hand, and not via C<< allow() >>) an authorisation may not
559             have an identifier. In these cases, the list will contain
560             undef.
561              
562             =item C<< $acl->allow(%args) >>
563              
564             Adds an authorisation to the ACL. The ACL must be mutable.
565              
566             The method takes a hash of named arguments:
567              
568             my $authid = $acl->allow(
569             webid => 'http://example.com/joe#me',
570             item => 'http://example.com/private/document',
571             level => ['Read', 'Write'],
572             );
573              
574             'item' is the URI of the item to authorise access to. As an alternative,
575             'item_class' may be used to authorise access to an entire class of items
576             (using classes in the RDFS/OWL sense of the word). If neither of these
577             arguments is provided, then the method will throw an error. Both may be
578             provided. Either or both may be an arrayref, because an authorisation
579             may authorise access to more than one thing.
580              
581             'container' is an alternative to using 'item' or 'item_class'. It
582             specifies the URI for a resource which in some way is a container for
583             other resources. Setting authorisations for a container allows you
584             to set a default authorisation for new items created within that
585             container. (You must use the C<< created() >> method to notify the ACL
586             about newly created items.)
587              
588             'webid' is the WebID (URI) of the person or agent being granted access.
589             As an alternative, 'agent_class' may be used to authorise access to an
590             entire class of agents. If neither is provided, an agent_class of
591             E<lt>http://xmlns.com/foaf/0.1/AgentE<gt> is assumed. Both may be
592             provided. Either or both may be an arrayref, because an authorisation
593             may authorise access by more than one agent. (For consistency with 'item',
594             'agent' is supported as a synonym for 'webid'.)
595              
596             'level' is the access level being granted. As with the C<< check >>
597             method, the shortcuts 'read', 'write', 'append' and 'control' may be used.
598             An arrayref may be used. If no level is specified, 'read' is assumed.
599              
600             This authorisation is not automatically saved, so it is probably useful
601             to call C<< save() >> after adding authorisations.
602              
603             The method returns an identifier for the authorisation. This identifier
604             may be needed again if you ever need to C<< deny() >> the authorisation.
605              
606             This method is aware of C<< i_am() >>/C<< who_am_i() >>.
607              
608             =item C<< $acl->deny($authid) >>
609              
610             Completely removes all traces of an authorisation from the ACL.
611              
612             The authorisation identifier can be found using C<< why() >> or
613             you may have remembered it when you first allowed the access.
614             In some cases (especially if the authorisation was created
615             by hand, and not via C<< allow() >>) an authorisation may not
616             have an identifier. In these cases, you will have to be creative
617             in figuring out how to deny access.
618              
619             Returns the number of statements removed from the ACL's internal model
620             as a result of the removal. (This will normally be at least 3.)
621              
622             This authorisation is not automatically saved, so it is probably useful
623             to call C<< save() >> after removing authorisations.
624              
625             This method is aware of C<< i_am() >>/C<< who_am_i() >>.
626              
627             =item C<< $acl->created($item, $container) >>
628              
629             Finds all authorisations which are the default for new items within
630             $container and clones each of them for newly created $item.
631              
632             Returns a list of authorisation identifiers.
633              
634             =item C<< $acl->i_am($webid) >>
635              
636             Tells the ACL object to "act like" the agent with the given WebID.
637              
638             If the ACL object is acting like you, then methods that make changes
639             to the ACL (e.g. C<< allow() >> and C<< deny() >>) will only work
640             if you have 'Control' permission over the resources specified.
641              
642             $webid can be null to restore the usual behaviour.
643              
644             Returns the previous WebID the ACL was acting like as a L<URI>
645             object.
646              
647             =item C<< $acl->who_am_i >>
648              
649             Returns the WebID of the agent that ACL is acting like (if any).
650              
651             =item C<< $acl->save($format, $filename) >>
652              
653             Serialises a local (not remote) ACL.
654              
655             $format can be any format supported by the C<serialize> function from
656             L<RDF::TrineX::Functions>.
657              
658             If $filename is provided, this method writes to the file
659             and returns the new file size in bytes.
660              
661             If $filename is omitted, this method does not attempt to write
662             to a file, and simply returns the string it would have written.
663              
664             =item C<< $acl->is_remote >>
665              
666             Returns true if the ACL is remote; false if local.
667              
668             =item C<< $acl->is_mutable >>
669              
670             Can this ACL be modified?
671              
672             =item C<< $acl->model >>
673              
674             The graph model against which authorisation checks are made.
675              
676             Returned as an L<RDF::Trine::Model> object.
677              
678             =item C<< $acl->endpoint >>
679              
680             The endpoint URI for remote (non-local) ACL queries.
681              
682             Returned as a L<URI> object.
683              
684             =back
685              
686             =head1 BUGS
687              
688             Please report any bugs to L<http://rt.cpan.org/>.
689              
690             =head1 SEE ALSO
691              
692             L<Web::ID>.
693              
694             L<http://www.w3.org/ns/auth/acl.n3>.
695              
696             L<http://www.perlrdf.org/>, L<http://lists.foaf-project.org/mailman/listinfo/foaf-protocols>.
697              
698             =head1 AUTHOR
699              
700             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
701              
702             =head1 COPYRIGHT AND LICENCE
703              
704             This software is copyright (c) 2010-2013 by Toby Inkster.
705              
706             This is free software; you can redistribute it and/or modify it under
707             the same terms as the Perl 5 programming language system itself.
708              
709             =head1 DISCLAIMER OF WARRANTIES
710              
711             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
712             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
713             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
714              
715