whatpm/Whatpm/CacheManifest.pm

package Whatpm::CacheManifest;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::URI::URIReference;

sub parse_byte_string ($$$$$) {
  require Encode;
  my $s = Encode::decode ('utf-8', $_[1]);
  return $_[0]->_parse (\$s, $_[2], $_[3], $_[4] || sub {
    my %err = @_;
    warn $err{type}, "\n";
  });
} # parse_byte_string

sub parse_char_string ($$$$$) {
  return $_[0]->_parse (\($_[1]), $_[2], $_[3], $_[4] || sub {
    my %err = @_;
    warn $err{type}, "\n";
  });
} # parse_char_string

sub _parse ($$$$$) {
  #my (undef, $input, $manifest_uri, $base_uri, $onerror) = @_;

  ## NOTE: A manifest MUST be labeled as text/cache-manifest.  (This should
  ## be checked in upper-level).
  ## NOTE: No "MUST" for being UTF-8.
  ## NOTE: A |text/cache-manifest| MUST be a cache manifest.
  ## NOTE: Newlines MUST be CR/CRLF/LF.  (We don't and can't check this.)

  ## ISSUE: In RFC 2046: "The specification for any future subtypes of "text" must specify whether or not they will also utilize a "charset" parameter"

  my $m_uri = Message::DOM::DOMImplementation->create_uri_reference ($_[2]);
  my $m_scheme = $m_uri->uri_scheme;

  my $onerror = $_[4];
  my $must_level = 'm';
  my $warn_level = 'w';
  my $line_number = 1;

  ## Same scheme/host/port
  my $same_shp = sub {
    ## TODO: implement this algorithm correctly!

    my $u1 = shift;
    
    unless (lc $u1->uri_scheme eq lc $m_scheme) {
      return 0;
    }

    return 0 unless defined $u1->uri_authority;
    return 0 unless defined $m_uri->uri_authority;

    return 0 unless $u1->uri_host eq $m_uri->uri_host;
    return 0 unless $u1->uri_port eq $m_uri->uri_port;

    return 1;
  }; # $same_shp

  ## Step 5
  my $input = $_[1];
  
  ## Step 1: MUST bytes --UTF-8--> characters.
  ## NOTE: illegal(s) -> U+FFFD, U+0000 -> U+FFFD
  $$input =~ tr/\x00/\x{FFFD}/;

  ## Step 2
  my $explicit_uris = [];

  ## Step 3
  my $fallback_uris = {};

  ## Step 4
  my $online_whitelist_uris = [];

  ## Step 6
  pos ($$input) = 0;

  ## Step 7
  ## Skip BOM ## NOTE: MAY in syntax.

  ## Step 8-10
  unless ($$input =~ /^CACHE MANIFEST[\x20\x09]*(?![^\x0D\x0A])/gc) {
    $onerror->(type => 'not manifest', level => $must_level,
               line => $line_number, column => 1); ## NOTE: MUST in syntax.
    return; ## Not a manifest.
  }

  ## Step 11
  ## This is a cache manifest.

  ## Step 12
  my $mode = 'explicit';

  ## NOTE: MUST be (blank line|comment|section head|data for the current
  ## section)*.

  ## Step 13
  START_OF_LINE: while (pos $$input < length $$input) {
    $$input =~ /([\x0A\x0D\x20\x09]+)/gc;
    my $v = $1;
    $line_number++ for $v =~ /\x0D\x0A?|\x0D/g;

    ## Step 14
    $$input =~ /([^\x0A\x0D]*)/gc;
    my $line = $1;

    ## Step 15
    next START_OF_LINE if $line =~ /^#/;

    ## Step 16
    $line =~ s/[\x20\x09]+\z//;

    if ($line eq 'CACHE:') {
      ## Step 17
      $mode = 'explicit';
      next START_OF_LINE;
    } elsif ($line eq 'FALLBACK:') {
      ## Step 18
      $mode = 'fallback';
      next START_OF_LINE;
    } elsif ($line eq 'NETWORK:') {
      ## Step 19
      $mode = 'online whitelist';
      next START_OF_LINE;
    }

    ## NOTE: "URIs that are to be fallback pages associated with
    ## opportunistic caching namespaces, and those namespaces themselves,
    ## MUST be given in fallback sections, with the namespace being the
    ## first URI of the data line, and the corresponding fallback page
    ## being the second URI. All the other pages to be cached MUST be
    ## listed in explicit sections." in writing section can't be tested.
    ## NOTE: "URIs that the user agent is to put into the online whitelist
    ## MUST all be specified in online whitelist sections." in writing
    ## section can't be tested.

    ## NOTE: "Relative URIs MUST be given relative to the manifest's own URI."
    ## requirement in writing section can't be tested.

    ## Step 20
    if ($mode eq 'explicit') {
      my $uri = Message::DOM::DOMImplementation->create_uri_reference ($line);

      unless ($uri->is_iri_reference_3987) {
        $onerror->(type => 'URI::syntax error:iriref3987',
                   level => $must_level, line => $line_number, column => 1,
                   value => $line);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      $uri = $uri->get_absolute_reference ($_[3]);

      if (defined $uri->uri_fragment) {
        $uri->uri_fragment (undef);
        $onerror->(type => 'URI fragment not allowed',
                   level => $must_level, line => $line_number, column => 1,
                   value => $line);
        ## NOTE: MUST in writing section.
      }

      my $scheme = $uri->uri_scheme;
      unless (defined $scheme and $scheme eq $m_scheme) {
        $onerror->(type => 'different scheme from manifest',
                   level => $warn_level, line => $line_number, column => 1,
                   value => $uri->uri_reference);
        next START_OF_LINE;
      }
      ## ISSUE: case-insensitive?

      push @$explicit_uris, $uri->uri_reference;
    } elsif ($mode eq 'fallback') {
      my ($p1, $p2) = split /[\x20\x09]+/, $line, 2;

      unless (defined $p2) {
        $onerror->(type => 'no fallback entry URI',
                   level => $must_level, line => $line_number, column => 1,
                   value => $line);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      my $u1 = Message::DOM::DOMImplementation->create_uri_reference ($p1);

      unless ($u1->is_iri_reference_3987) {
        $onerror->(type => 'URI::syntax error:iriref3987',
                   level => $must_level, line => $line_number, column => 1,
                   index => 0, value => $p1);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      my $u2 = Message::DOM::DOMImplementation->create_uri_reference ($p2);

      unless ($u2->is_iri_reference_3987) {
        $onerror->(type => 'URI::syntax error:iriref3987',
                   level => $must_level, line => $line_number, column => 1,
                   index => 1, value => $p2);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      if (defined $u1->uri_fragment) {
        $onerror->(type => 'URI fragment not allowed',
                   level => $must_level, line => $line_number, column => 1,
                   index => 0, value => $p1);
        ## NOTE: MUST in writing section.
        ## ISSUE: Not dropped
      }

      if (defined $u2->uri_fragment) {
        $onerror->(type => 'URI fragment not allowed',
                   level => $must_level, line => $line_number, column => 1,
                   index => 1, value => $p2);
        ## NOTE: MUST in writing section.
        ## ISSUE: Not dropped
      }

      $u1 = $u1->get_absolute_reference ($_[3]);
      $u2 = $u2->get_absolute_reference ($_[3]);

      if (exists $fallback_uris->{$u1->uri_reference}) {
        $onerror->(type => 'duplicate oc namespace',
                   level => $must_level, line => $line_number, column => 1,
                   index => 0, value => $u1->uri_reference);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }
      
      unless ($same_shp->($u1)) {
        $onerror->(type => 'different shp from manifest',
                   level => $must_level, line => $line_number, column => 1,
                   index => 0, value => $u1->uri_reference);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      my $u2_scheme = $u2->uri_scheme;
      unless (defined $u2_scheme and $u2_scheme eq $m_scheme) {
        $onerror->(type => 'different scheme from manifest',
                   level => $warn_level, line => $line_number, column => 1,
                   index => 1, value => $u2->uri_reference);
        next START_OF_LINE;
      }

      $fallback_uris->{$u1->uri_reference} = $u2->uri_reference;
    } elsif ($mode eq 'online whitelist') {
      my $uri = Message::DOM::DOMImplementation->create_uri_reference ($line);

      unless ($uri->is_iri_reference_3987) {
        $onerror->(type => 'URI::syntax error:iriref3987',
                   level => $must_level, line => $line_number, column => 1,
                   value => $line);
        next START_OF_LINE; ## NOTE: MUST in syntax.
      }

      $uri = $uri->get_absolute_reference ($_[3]);

      if (defined $uri->uri_fragment) {
        $uri->uri_fragment (undef);
        $onerror->(type => 'URI fragment not allowed',
                   level => $must_level, line => $line_number, column => 1,
                   value => $line);
        ## NOTE: MUST in writing section.
      }

      my $scheme = $uri->uri_scheme;
      unless (defined $scheme and $scheme eq $m_scheme) {
        $onerror->(type => 'different scheme from manifest',
                   level => $warn_level, line => $line_number, column => 1,
                   value => $uri->uri_reference);
        next START_OF_LINE;
      }

      push @$online_whitelist_uris, $uri->uri_reference;      
    }

    ## Step 21
    #next START_OF_LINE;
  } # START_OF_LINE

  ## Step 22
  return [$explicit_uris, $fallback_uris, $online_whitelist_uris];
} # _parse

sub check_manifest ($$$) {
  my (undef, $manifest, $onerror) = @_;

  my $listed = {};
  my $must_level = 'm';

  require Whatpm::URIChecker;

  for my $uri (@{$manifest->[0]}) {
    $listed->{$uri} = 1;

    Whatpm::URIChecker->check_iri_reference ($uri, sub {
      my %opt = @_;
      $onerror->(level => $opt{level}, value => $uri,
                 type => 'URI::'.$opt{type}.
                 (defined $opt{position} ? ':'.$opt{position} : ''));
    });
  }

  for my $uri (values %{$manifest->[1]}) {
    $listed->{$uri} = 1;

    Whatpm::URIChecker->check_iri_reference ($uri, sub {
      my %opt = @_;
      $onerror->(level => $opt{level}, index => 1, value => $uri,
                 type => 'URI::'.$opt{type}.
                 (defined $opt{position} ? ':'.$opt{position} : ''));
    });
  }

  for my $uri (keys %{$manifest->[1]}) { 
    Whatpm::URIChecker->check_iri_reference ($uri, sub {
      my %opt = @_;
      $onerror->(level => $opt{level}, index => 0, value => $uri,
                 type => 'URI::'.$opt{type}.
                 (defined $opt{position} ? ':'.$opt{position} : ''));
    });
  }

  for my $uri (@{$manifest->[2]}) {
    if ($listed->{$uri}) {
      $onerror->(type => 'both in entries and whitelist',
                 level => $must_level, value => $uri);
      ## NOTE: MUST in writing section.
    }

    Whatpm::URIChecker->check_iri_reference ($uri, sub {
      my %opt = @_;
      $onerror->(level => $opt{level}, value => $uri,
                 type => 'URI::'.$opt{type}.
                 (defined $opt{position} ? ':'.$opt{position} : ''));
    });
  }
} # check_manifest


=head1 LICENSE

Copyright 2007 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut

1;
# $Date: 2007/11/04 11:49:44 $
1	wakaba	1.1	package Whatpm::CacheManifest;
2			use strict;
3	wakaba	1.2	our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
4	wakaba	1.1	require Message::URI::URIReference;
5
6			sub parse_byte_string ($$$$$) {
7			require Encode;
8			my $s = Encode::decode ('utf-8', $_[1]);
9			return $_[0]->_parse (\$s, $_[2], $_[3], $_[4] \|\| sub {
10			my %err = @_;
11			warn $err{type}, "\n";
12			});
13			} # parse_byte_string
14
15			sub parse_char_string ($$$$$) {
16			return $_[0]->_parse (\($_[1]), $_[2], $_[3], $_[4] \|\| sub {
17			my %err = @_;
18			warn $err{type}, "\n";
19			});
20			} # parse_char_string
21
22			sub _parse ($$$$$) {
23			#my (undef, $input, $manifest_uri, $base_uri, $onerror) = @_;
24
25			## NOTE: A manifest MUST be labeled as text/cache-manifest. (This should
26			## be checked in upper-level).
27			## NOTE: No "MUST" for being UTF-8.
28			## NOTE: A \|text/cache-manifest\| MUST be a cache manifest.
29			## NOTE: Newlines MUST be CR/CRLF/LF. (We don't and can't check this.)
30
31	wakaba	1.2	## ISSUE: In RFC 2046: "The specification for any future subtypes of "text" must specify whether or not they will also utilize a "charset" parameter"
32
33	wakaba	1.1	my $m_uri = Message::DOM::DOMImplementation->create_uri_reference ($_[2]);
34			my $m_scheme = $m_uri->uri_scheme;
35
36			my $onerror = $_[4];
37			my $must_level = 'm';
38			my $warn_level = 'w';
39			my $line_number = 1;
40
41			## Same scheme/host/port
42			my $same_shp = sub {
43			## TODO: implement this algorithm correctly!
44
45			my $u1 = shift;
46
47			unless (lc $u1->uri_scheme eq lc $m_scheme) {
48			return 0;
49			}
50
51			return 0 unless defined $u1->uri_authority;
52			return 0 unless defined $m_uri->uri_authority;
53
54			return 0 unless $u1->uri_host eq $m_uri->uri_host;
55			return 0 unless $u1->uri_port eq $m_uri->uri_port;
56
57			return 1;
58			}; # $same_shp
59
60			## Step 5
61			my $input = $_[1];
62
63			## Step 1: MUST bytes --UTF-8--> characters.
64			## NOTE: illegal(s) -> U+FFFD, U+0000 -> U+FFFD
65			$$input =~ tr/\x00/\x{FFFD}/;
66
67			## Step 2
68			my $explicit_uris = [];
69
70			## Step 3
71			my $fallback_uris = {};
72
73			## Step 4
74			my $online_whitelist_uris = [];
75
76			## Step 6
77			pos ($$input) = 0;
78
79			## Step 7
80			## Skip BOM ## NOTE: MAY in syntax.
81
82			## Step 8-10
83			unless ($$input =~ /^CACHE MANIFEST[\x20\x09]*(?![^\x0D\x0A])/gc) {
84			$onerror->(type => 'not manifest', level => $must_level,
85			line => $line_number, column => 1); ## NOTE: MUST in syntax.
86			return; ## Not a manifest.
87			}
88
89			## Step 11
90			## This is a cache manifest.
91
92			## Step 12
93			my $mode = 'explicit';
94
95			## NOTE: MUST be (blank line\|comment\|section head\|data for the current
96			## section)*.
97
98			## Step 13
99			START_OF_LINE: while (pos $$input < length $$input) {
100			$$input =~ /([\x0A\x0D\x20\x09]+)/gc;
101			my $v = $1;
102			$line_number++ for $v =~ /\x0D\x0A?\|\x0D/g;
103
104			## Step 14
105			$$input =~ /([^\x0A\x0D]*)/gc;
106			my $line = $1;
107
108			## Step 15
109			next START_OF_LINE if $line =~ /^#/;
110
111			## Step 16
112			$line =~ s/[\x20\x09]+\z//;
113
114			if ($line eq 'CACHE:') {
115			## Step 17
116			$mode = 'explicit';
117			next START_OF_LINE;
118			} elsif ($line eq 'FALLBACK:') {
119			## Step 18
120			$mode = 'fallback';
121			next START_OF_LINE;
122			} elsif ($line eq 'NETWORK:') {
123			## Step 19
124			$mode = 'online whitelist';
125			next START_OF_LINE;
126			}
127
128			## NOTE: "URIs that are to be fallback pages associated with
129			## opportunistic caching namespaces, and those namespaces themselves,
130			## MUST be given in fallback sections, with the namespace being the
131			## first URI of the data line, and the corresponding fallback page
132			## being the second URI. All the other pages to be cached MUST be
133			## listed in explicit sections." in writing section can't be tested.
134			## NOTE: "URIs that the user agent is to put into the online whitelist
135			## MUST all be specified in online whitelist sections." in writing
136			## section can't be tested.
137
138			## NOTE: "Relative URIs MUST be given relative to the manifest's own URI."
139			## requirement in writing section can't be tested.
140
141			## Step 20
142			if ($mode eq 'explicit') {
143			my $uri = Message::DOM::DOMImplementation->create_uri_reference ($line);
144
145			unless ($uri->is_iri_reference_3987) {
146			$onerror->(type => 'URI::syntax error:iriref3987',
147			level => $must_level, line => $line_number, column => 1,
148			value => $line);
149			next START_OF_LINE; ## NOTE: MUST in syntax.
150			}
151
152			$uri = $uri->get_absolute_reference ($_[3]);
153
154			if (defined $uri->uri_fragment) {
155			$uri->uri_fragment (undef);
156			$onerror->(type => 'URI fragment not allowed',
157			level => $must_level, line => $line_number, column => 1,
158			value => $line);
159			## NOTE: MUST in writing section.
160			}
161
162			my $scheme = $uri->uri_scheme;
163			unless (defined $scheme and $scheme eq $m_scheme) {
164			$onerror->(type => 'different scheme from manifest',
165			level => $warn_level, line => $line_number, column => 1,
166			value => $uri->uri_reference);
167			next START_OF_LINE;
168			}
169			## ISSUE: case-insensitive?
170
171			push @$explicit_uris, $uri->uri_reference;
172			} elsif ($mode eq 'fallback') {
173			my ($p1, $p2) = split /[\x20\x09]+/, $line, 2;
174
175			unless (defined $p2) {
176			$onerror->(type => 'no fallback entry URI',
177			level => $must_level, line => $line_number, column => 1,
178			value => $line);
179			next START_OF_LINE; ## NOTE: MUST in syntax.
180			}
181
182			my $u1 = Message::DOM::DOMImplementation->create_uri_reference ($p1);
183
184			unless ($u1->is_iri_reference_3987) {
185			$onerror->(type => 'URI::syntax error:iriref3987',
186			level => $must_level, line => $line_number, column => 1,
187			index => 0, value => $p1);
188			next START_OF_LINE; ## NOTE: MUST in syntax.
189			}
190
191			my $u2 = Message::DOM::DOMImplementation->create_uri_reference ($p2);
192
193			unless ($u2->is_iri_reference_3987) {
194			$onerror->(type => 'URI::syntax error:iriref3987',
195			level => $must_level, line => $line_number, column => 1,
196			index => 1, value => $p2);
197			next START_OF_LINE; ## NOTE: MUST in syntax.
198			}
199
200			if (defined $u1->uri_fragment) {
201			$onerror->(type => 'URI fragment not allowed',
202			level => $must_level, line => $line_number, column => 1,
203			index => 0, value => $p1);
204			## NOTE: MUST in writing section.
205			## ISSUE: Not dropped
206			}
207
208			if (defined $u2->uri_fragment) {
209			$onerror->(type => 'URI fragment not allowed',
210			level => $must_level, line => $line_number, column => 1,
211			index => 1, value => $p2);
212			## NOTE: MUST in writing section.
213			## ISSUE: Not dropped
214			}
215
216			$u1 = $u1->get_absolute_reference ($_[3]);
217			$u2 = $u2->get_absolute_reference ($_[3]);
218
219			if (exists $fallback_uris->{$u1->uri_reference}) {
220			$onerror->(type => 'duplicate oc namespace',
221			level => $must_level, line => $line_number, column => 1,
222			index => 0, value => $u1->uri_reference);
223			next START_OF_LINE; ## NOTE: MUST in syntax.
224			}
225
226			unless ($same_shp->($u1)) {
227			$onerror->(type => 'different shp from manifest',
228			level => $must_level, line => $line_number, column => 1,
229			index => 0, value => $u1->uri_reference);
230			next START_OF_LINE; ## NOTE: MUST in syntax.
231			}
232
233			my $u2_scheme = $u2->uri_scheme;
234			unless (defined $u2_scheme and $u2_scheme eq $m_scheme) {
235			$onerror->(type => 'different scheme from manifest',
236			level => $warn_level, line => $line_number, column => 1,
237			index => 1, value => $u2->uri_reference);
238			next START_OF_LINE;
239			}
240
241			$fallback_uris->{$u1->uri_reference} = $u2->uri_reference;
242			} elsif ($mode eq 'online whitelist') {
243			my $uri = Message::DOM::DOMImplementation->create_uri_reference ($line);
244
245			unless ($uri->is_iri_reference_3987) {
246			$onerror->(type => 'URI::syntax error:iriref3987',
247			level => $must_level, line => $line_number, column => 1,
248			value => $line);
249			next START_OF_LINE; ## NOTE: MUST in syntax.
250			}
251
252			$uri = $uri->get_absolute_reference ($_[3]);
253
254			if (defined $uri->uri_fragment) {
255			$uri->uri_fragment (undef);
256			$onerror->(type => 'URI fragment not allowed',
257			level => $must_level, line => $line_number, column => 1,
258			value => $line);
259			## NOTE: MUST in writing section.
260			}
261
262			my $scheme = $uri->uri_scheme;
263			unless (defined $scheme and $scheme eq $m_scheme) {
264			$onerror->(type => 'different scheme from manifest',
265			level => $warn_level, line => $line_number, column => 1,
266			value => $uri->uri_reference);
267			next START_OF_LINE;
268			}
269
270			push @$online_whitelist_uris, $uri->uri_reference;
271			}
272
273			## Step 21
274			#next START_OF_LINE;
275			} # START_OF_LINE
276
277			## Step 22
278			return [$explicit_uris, $fallback_uris, $online_whitelist_uris];
279			} # _parse
280
281			sub check_manifest ($$$) {
282			my (undef, $manifest, $onerror) = @_;
283
284			my $listed = {};
285			my $must_level = 'm';
286
287			require Whatpm::URIChecker;
288
289			for my $uri (@{$manifest->[0]}) {
290			$listed->{$uri} = 1;
291
292			Whatpm::URIChecker->check_iri_reference ($uri, sub {
293			my %opt = @_;
294			$onerror->(level => $opt{level}, value => $uri,
295			type => 'URI::'.$opt{type}.
296			(defined $opt{position} ? ':'.$opt{position} : ''));
297			});
298			}
299
300			for my $uri (values %{$manifest->[1]}) {
301			$listed->{$uri} = 1;
302
303			Whatpm::URIChecker->check_iri_reference ($uri, sub {
304			my %opt = @_;
305			$onerror->(level => $opt{level}, index => 1, value => $uri,
306			type => 'URI::'.$opt{type}.
307			(defined $opt{position} ? ':'.$opt{position} : ''));
308			});
309			}
310
311			for my $uri (keys %{$manifest->[1]}) {
312			Whatpm::URIChecker->check_iri_reference ($uri, sub {
313			my %opt = @_;
314			$onerror->(level => $opt{level}, index => 0, value => $uri,
315			type => 'URI::'.$opt{type}.
316			(defined $opt{position} ? ':'.$opt{position} : ''));
317			});
318			}
319
320			for my $uri (@{$manifest->[2]}) {
321			if ($listed->{$uri}) {
322			$onerror->(type => 'both in entries and whitelist',
323			level => $must_level, value => $uri);
324			## NOTE: MUST in writing section.
325			}
326
327			Whatpm::URIChecker->check_iri_reference ($uri, sub {
328			my %opt = @_;
329			$onerror->(level => $opt{level}, value => $uri,
330			type => 'URI::'.$opt{type}.
331			(defined $opt{position} ? ':'.$opt{position} : ''));
332			});
333			}
334			} # check_manifest
335
336
337			=head1 LICENSE
338
339			Copyright 2007 Wakaba <w@suika.fam.cx>
340
341			This library is free software; you can redistribute it
342			and/or modify it under the same terms as Perl itself.
343
344			=cut
345
346			1;
347	wakaba	1.2	# $Date: 2007/11/04 11:49:44 $