#!/usr/bin/perl
#
# This script queries a WMS service by requesting its capabilities
# (REQUEST=GetCapabilities) and constructs a GDAL WMS input file form the
# returned data.
#
# Written and Copyright (C) by Albrecht Dreß <albrecht.dress@arcor.de> 2011
#
# This script is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License <http://www.gnu.org/licenses/> for more
# details.
#
# Usage:
# At least, the script must be called with the argument '--base=<URL>' which
# gives the base URL of the service.  Note that the terminating question mark
# '?' must not be included.  The script will then print a list of all layers
# available.
#
# As to construct a GDAL WMS file, re-un the script, and add the layer name
# as '--layer=<name>'.  Optionally, add '--outfile=<name>' to specify the
# output file name instead of the default (constructed from URL and layer
# name, printed by the script).  Add '--size=<size>' to specify a DataWindow
# size, the default is 1M.
#
# Environment variables:
# HTTP_PROXY: if set, it us used.  Note that authentication is not supported.
# TMPDIR: base folder for the GDAL cache, otherwise '/tmp' is used.

use HTTP::Lite;
use Getopt::Long;
use XML::Simple;
use utf8;
use strict;

sub print_usage();
sub inherit_srs($$);
sub find_layer($$$$);
sub pr_layer_info($$);

# set to the full path of the 'proj' application if this one doesn't fit...
my $proj = '/usr/bin/proj';

my $baseurl = '';
my $pixelsize = 50;
my $outfile = '';
my $wmsver = '1.1.1';
my $layer = '';
GetOptions('base=s'    => \$baseurl,
           'size=f'    => \$pixelsize,
           'outfile=s' => \$outfile,
           'layer=s'   => \$layer);
print_usage() if ($baseurl eq '');

# send the GetCapabilities request
my $http = new HTTP::Lite;
if (defined $ENV{'HTTP_PROXY'}) {
	my $proxy = $ENV{'HTTP_PROXY'};
	$proxy =~ s;^http://;;;		# HTTP::Lite doesn't like URL's...
	$http->proxy($proxy);
}
my $requrl = $baseurl;
if ($requrl =~ m/[?]/) {
    $requrl .= "&SERVICE=WMS&VERSION=$wmsver&REQUEST=GetCapabilities";
} else {
    $requrl .= "?SERVICE=WMS&VERSION=$wmsver&REQUEST=GetCapabilities";
}
print "Trying to read capabilities from $requrl...\n";
my $req = $http->request($requrl)
    or die "ERROR: unable to get document: $!\n";
die "ERROR: HTTP result $req received\n"
    if ($req < 200 or $req > 299);
my $content = $http->get_header('Content-Type')
    or die "ERROR: unable to get content type: $!\n";
die "ERROR: bad content type $$content[0]\n"
    unless ($$content[0] =~ m;^application/vnd.ogc.wms_xml; or $$content[0] =~ m;.*/xml;);

# parse the received XML body
my $xml_caps = XMLin($http->body());
my $serverurl = $xml_caps->{'Capability'}->{'Request'}->{'GetMap'}->
    {'DCPType'}->{'HTTP'}->{'Get'}->{'OnlineResource'}->{'xlink:href'}
    or die "ERROR: no URL for a Get Map HTTP GET request\n";

# print a list of available layers if none is given
if ($layer eq '') {
    print "\nsupported layers from '$baseurl', WMS version $wmsver:\n\n";
    pr_layer_info($xml_caps->{'Capability'}->{'Layer'}, 1);
    print "\nHint: re-run with '--layer=<name>'\n\n"; 
    exit 0;
}

# grab the requested layer
my $use_layer =
    find_layer($xml_caps->{'Capability'}->{'Layer'}, $layer, undef, undef);
die "ERROR: cannot find layer '$layer', re-run without '--layer=$layer' to get a list\n"
    unless (defined $use_layer);
my $boundingbox = $use_layer->{'LatLonBoundingBox'}
    or die "ERROR: no Bounding Box\n";
print "Bounding box: ($$boundingbox{'minx'}; $$boundingbox{'miny'}) .. ($$boundingbox{'maxx'}; $$boundingbox{'maxy'})\n";
my @min_m = split /\s/, `echo "$$boundingbox{'minx'} $$boundingbox{'miny'}" | $proj +proj=tmerc`;
my @max_m = split /\s/, `echo "$$boundingbox{'maxx'} $$boundingbox{'maxy'}" | $proj +proj=tmerc`;
my ($xsize, $ysize);
$ysize = ($max_m[0] - $min_m[0]) / 1000;
$xsize = ($max_m[1] - $min_m[1]) / 1000;
print "Approx. size: $xsize x $ysize km\n";

# check if EPSG:4326 is supported, otherwise choose the first from the list
die "ERROR: no SRS definition\n"
	if (!defined $use_layer->{'SRS'});
my $srs;
if (grep (/^epsg:4326$/i, @{$use_layer->{'SRS'}})) {
    $srs = 'EPSG:4326';
} else {
    $srs = ${$use_layer->{'SRS'}}[0];
}

# check if image/jpeg, image/png or image/tiff are supported
my $format = '';
my $ext;
foreach my $testfmt ('image/jpeg', 'image/png', 'image/tiff') {
    if (grep (/$testfmt/i, @{$xml_caps->{'Capability'}->{'Request'}->
                           {'GetMap'}->{'Format'}})) {
        $ext = $format = $testfmt;
        last;
    }
}
die "ERROR: no usable file format\n"
    unless ($format ne '');
$ext =~ s;.*/;.;;

# print abstract and access constraints
print "\nService Abstract:\n", $xml_caps->{'Service'}->{'Abstract'}, "\n\n";
print "Access Constraints:\n", $xml_caps->{'Service'}->{'AccessConstraints'}, "\n\n";

# create the GDAL file
if ($outfile eq '') {
    $outfile = $baseurl;
    $outfile =~ s;^http://;;;
    $outfile =~ s;[./];_;g;
    $outfile .= "_$layer.xml";
}
my $tmppath;
if (defined $ENV{'TMPDIR'}) {
	$tmppath = $ENV{'TMPDIR'};
} else {
	$tmppath = '/tmp';
}
$tmppath .= '/' . getpwuid($<) . '/gdalwmscache';

print "Storing GDAL file to $outfile...\n";
open OUT, "> $outfile";
my $gdal_out = {
    'Service' => {
        'name' => [ 'WMS' ],
        'Version' => [ $wmsver ],
        'ServerUrl' => [ $serverurl ],
        'SRS' => [ $srs ],
        'ImageFormat' => [ $format ],
        'Layers' => [ $layer ]
    },
    'DataWindow' => {
        'UpperLeftX' => [ $$boundingbox{'minx'} ],
        'UpperLeftY' => [ $$boundingbox{'maxy'} ],
        'LowerRightX' => [ $$boundingbox{'maxx'} ],
        'LowerRightY' => [ $$boundingbox{'miny'} ],
        'SizeX' => [ int($xsize * 1000 / $pixelsize) ],
        'SizeY' => [ int($xsize * 1000 / $pixelsize) ]
    },
    'BlockSizeX' => [ 200 ],
    'BlockSizeY' => [ 200 ],
    'Cache' => {
        'Path' => [ $tmppath ],
        'Depth' => [ 2 ],
        'Extension' => [ $ext ]
    },
    'MaxConnections' => [ 2 ],
    'Timeout' => [ 30 ],
    'OfflineMode' => [ 'false' ],
    'AdviseRead' => [ 'false' ],
    'VerifyAdviseRead' => [ 'true' ],
    'ClampRequests' => [ 'true' ],
    'UserAgent' => [ 'GDAL WMS driver (http://www.gdal.org/frmt_wms.html)' ]
};
print OUT XMLout($gdal_out, RootName => 'GDAL_WMS');
close OUT;
print "done\n\n";
exit 0;


sub inherit_srs($$)
{
	my $srs1 = shift;
	my $srs2 = shift;
	my @result;

	if (defined $srs1) {
		if (ref($srs1) eq 'ARRAY') {
			@result = @{$srs1};
		} else {
			@result = $srs1;
		}
	}
	if (defined $srs2) {
		if (ref($srs2) eq 'ARRAY') {
			@result = ( @result, @{$srs2} );
		} else {
			@result = ( @result, $srs2 );
		}
	}

	return \@result;
}


sub find_layer($$$$)
{
    my $layer = shift;
    my $name = shift;
    my $bbox = shift;
	my $srs = shift;
    my $the_layer;
    
    if (ref($layer) eq 'ARRAY') {
        foreach my $this_layer (@{$layer}) {
            $this_layer->{'LatLonBoundingBox'} = $bbox
                unless (defined $this_layer->{'LatLonBoundingBox'});
			$this_layer->{'SRS'} = inherit_srs($this_layer->{'SRS'}, $srs);
          	$the_layer = find_layer($this_layer, $name, $this_layer->{'LatLonBoundingBox'}, $this_layer->{'SRS'});
            return $the_layer if (defined $the_layer);
        }
    } else {
        $layer->{'LatLonBoundingBox'} = $bbox
            unless (defined $layer->{'LatLonBoundingBox'});
		$layer->{'SRS'} = inherit_srs($layer->{'SRS'}, $srs);
        return $layer if ($layer->{'Name'} eq $name);
        if (exists($layer->{'Layer'})) {
            $the_layer = find_layer($layer->{'Layer'}, $name, $layer->{'LatLonBoundingBox'}, $layer->{'SRS'});
            return $the_layer if (defined $the_layer)
        }
    }
    return undef;        
}


sub pr_layer_info($$)
{
    my $layer = shift;
    my $level = shift;

    if (ref($layer) eq 'ARRAY') {
        foreach my $this_layer (@{$layer}) {
            pr_layer_info($this_layer, $level);
        }
    } else {
        if (exists $layer->{'Name'}) {
            my $title = $layer->{'Title'};
            $title = '(no title)' unless ($title ne '');
            my $abstract = $layer->{'Abstract'};
            $abstract = '(no abstract)' unless ($abstract ne '');
            printf "%${level}clayer name '%s': $title\n\t$abstract\n", '', $layer->{'Name'};
            printf "\tscale hint: $layer->{'ScaleHint'}->{'min'} .. $layer->{'ScaleHint'}->{'max'}\n"
                if (exists $layer->{'ScaleHint'});
        }
        pr_layer_info($layer->{'Layer'}, $level + 2) if (exists $layer->{'Layer'});
    }
}


sub print_usage()
{
    print <<EOF;

usage: $0 <options>

Options:
  --base=<base>         base URL
  --layer=<layer>       Layer name, omit to print list
  --size=<size>         pixel size in m (default 50)
  --outfile=<filename>  output file name

Written and Copyright (C) by Albrecht Dre\xc3\x9f <albrecht.dress\@arcor.de> 2011

This script is free software: you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation, either version 3 of the License, or (at your option)
any later version.  Please see the source code for details.

EOF
    exit 1;
}

