whatpm/Whatpm/CacheManifest.pm

package Whatpm::CacheManifest;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.50 $=~/\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.)

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