source: josm/trunk/scripts/TestHTTPS.pl @ 14626

Last change on this file since 14626 was 14626, checked in by stoecker, 4 months ago

see #16123 - support complete style/rule/preset scan using josm server cronjob output

  • Property svn:executable set to *
File size: 3.6 KB
Line 
1#! /usr/bin/perl -w
2
3use strict;
4use utf8;
5use open qw/:std :encoding(utf8)/;
6use Net::HTTPS;
7use XML::LibXML;
8
9my %urls;
10
11my %known = map {$_ => 1} qw(
12  siglon.londrina.pr.gov.br
13  tiles.itoworld.com
14  tms.cadastre.openstreetmap.fr
15  www.jgoodies.com
16  zibi.openstreetmap.org.pl
17);
18
19sub getmaps
20{
21  my $dom = XML::LibXML->load_xml(location => "imagery_josm.imagery.xml");
22  my $xpc = XML::LibXML::XPathContext->new($dom);
23  $xpc->registerNs('j',  'http://josm.openstreetmap.de/maps-1.0');
24  foreach my $entry ($xpc->findnodes("//j:entry"))
25  {
26    my $name = $xpc->findvalue("./j:name", $entry);
27    for my $e ($xpc->findnodes(".//j:*", $entry))
28    {
29      if($e->textContent =~ /^http:\/\/(.*?)[\/]/)
30      {
31        my $u = $1;
32        if($u =~ /^(.*)\{switch:(.*)\}(.*)$/)
33        {
34          my ($f,$switch,$e) = ($1, $2, $3);
35          for my $s (split(",", $switch))
36          {
37            $urls{"$f$s$e"}{"MAP:$name"}++;
38          }
39        }
40        else
41        {
42          $urls{$u}{"MAP:$name"}++;
43        }
44      }
45    }
46  }
47}
48
49sub getfile($$)
50{
51  my ($type, $file) = @_;
52  open FILE,"<:encoding(utf-8)",$file or die;
53  my $name;
54  for my $line (<FILE>)
55  {
56    if($line =~ /^([^ \t].*);(.*)/)
57    {
58      my ($n, $url) = ($1, $2);
59      if($url =~ /josm\.openstreetmap\.de/)
60      {
61        $name = "WIKI$type:$n";
62      }
63      else
64      {
65        $name = "$type:$n";
66      }
67    }
68    if($line =~ /http:\/\/(.*?)[\/]/)
69    {
70      $urls{$1}{$name}++;
71    }
72  }
73  close FILE;
74}
75
76sub getdump()
77{
78  open FILE,"<:encoding(utf-8)","josm_dump.txt" or die;
79  local $/;
80  undef $/;
81  my $file = <FILE>;
82  close FILE;
83  eval $file;
84}
85
86print "Options: \n PLUGIN STYLE RULE PRESET MAP DUMP\n GETPLUGIN GETSTYLE GETRULE GETPRESET GETMAP GETDUMP\n LOCAL\n ALL GETALL\n" if !@ARGV;
87
88open OUTFILE,">","josm_https.txt" or die "Could not open output file";
89
90sub doprint($)
91{
92  print OUTFILE $_[0];
93  print $_[0];
94}
95
96my $local = 0;
97for my $ARG (@ARGV)
98{
99  if($ARG eq "ALL") {push(@ARGV, "PLUGIN", "STYLE", "RULE", "PRESET", "MAP", "DUMP");}
100  if($ARG eq "GETALL") {push(@ARGV, "GETPLUGIN", "GETSTYLE", "GETRULE", "GETPRESET", "GETMAP", "GETDUMP");}
101}
102my %ARGS = map {$_ => 1} @ARGV; # prevent double arguments by passing through a hash
103for my $ARG (sort keys %ARGS)
104{
105  if($ARG eq "LOCAL") {$local = 1; }
106  if($ARG eq "GETDUMP") { system "scp josm\@josm.openstreetmap.de:auto/httpinfo.dump josm_dump.txt"; getdump();}
107  if($ARG eq "DUMP") { getdump(); }
108  if($ARG eq "GETMAP") { system "curl https://josm.openstreetmap.de/maps -o imagery_josm.imagery.xml"; getmaps();}
109  if($ARG eq "MAP") { getmaps(); }
110  for my $x ("PLUGIN", "STYLE", "RULE", "PRESET")
111  {
112    my $t = lc($x);
113    my $url = $x eq "PLUGIN" ? $t : "${t}s";
114    my $file = "josm_$t.xml";
115    if($ARG eq "GET$x") { system "curl https://josm.openstreetmap.de/$url -o $file"; getfile($x, $file);}
116    if($ARG eq $x) { getfile($x, $file); }
117  }
118}
119
120for my $url (sort keys %urls)
121{
122  my $i = join(" # ", sort keys %{$urls{$url}});
123  if($local) # skip test
124  {
125    doprint "* ".($known{$url} ? "~~" : "")."$url:$i\n";
126    next;
127  }
128  eval
129  {
130    local $SIG{ALRM} = sub {die "--Alarm--"};
131
132    alarm(5);
133    my $s = Net::HTTPS->new(Host => $url) || die $@;
134    $s->write_request(GET => "/", 'User-Agent' => "TestHTTPS/1.0");
135    my($code, $mess, %h) = $s->read_response_headers;
136    alarm(0);
137    doprint "* ".($known{$url} ? "~~" : "")."$url [$code $mess]: $i\n";
138  };
139  if($@ && $@ !~ "(--Alarm--|Connection refused)")
140  {
141    my $e = $@;
142    $e =~ s/[\r\n]//g;
143    $e =~ s/ at scripts\/TestHTTPS.pl .*//;
144    doprint "* ".($known{$url} ? "~~" : "")."$url [Error $e] :$i\n";
145  }
146}
Note: See TracBrowser for help on using the repository browser.