[dev] Introducing Sympa::Tools::Text::weburl() and Sympa::get_url() to construct web URLs.

Sympa::get_url() supports four modes: default, omit, remote and local.  See documentation.


git-svn-id: https://subversion.renater.fr/sympa/branches/sympa-6.2-branch@12721 05aa8bb8-cd2b-0410-b1d7-8918dfa770ce

src/lib/Sympa.pm

@@ -48,6 +48,7 @@ use DateTime;
 use Digest::MD5;
 use English qw(-no_match_vars);
 use Scalar::Util qw();
+use URI;
 
 use Conf;
 use Sympa::Constants;
@@ -1285,6 +1286,143 @@ sub get_listmasters_email {
 
 =over
 
+=item get_url ( $that, $action, [ nomenu =E<gt> 1 ], [ paths =E<gt> \@paths ],
+[ authority =E<gt> $mode ],
+[ options... ] )
+
+Returns URL for web interface.
+
+Parameters:
+
+=over
+
+=item $action
+
+Name of action.
+This is inserted into URL intact.
+
+=item authority =E<gt> $mode
+
+C<'default'> respects C<wwsympa_url> parameter.
+C<'remote'> replaces scheme, host and port using CGI environment variables.
+C<'local'> is similar but may additionally replace script path.
+C<'omit'> omits scheme and authority, i.e. returns relative URI.
+
+Note that C<'remote'> and C<'local'> modes work correctly only under
+CGI environment.
+
+=item nomenu =E<gt> 1
+
+Adds C<nomenu> modifier.
+
+=item paths =E<gt> \@paths
+
+Additional path components.
+Note that they are percent-encoded as necessity.
+
+=item options...
+
+See L<Sympa::Tools::Text/"weburl">.
+
+=back
+
+Returns:
+
+A string.
+
+Note:
+If $mode is C<'local'>, result is that Sympa server recognizes locally.
+In other cases, result is the URI that is used by end users to access to web
+interface.
+C<'local'> URI can be differ from others when, for example, the server is
+placed behind reverse proxy.
+
+=back
+
+=cut
+
+sub get_url {
+    my $that    = shift;
+    my $action  = shift;
+    my %options = @_;
+
+    my $robot_id =
+          (ref $that eq 'Sympa::List') ? $that->{'domain'}
+        : ($that and $that ne '*') ? $that
+        :                            '*';
+    my $option_authority = $options{authority} || 'default';
+
+    my $base;
+    if ($option_authority eq 'remote' or $option_authority eq 'local') {
+        my $uri = URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url'));
+
+        # Override scheme, host and port by actual ones.
+        if ($ENV{HTTPS} and $ENV{HTTPS} eq 'on') {
+            $uri->scheme('https');
+        }
+
+        my ($host_port, $port);
+        if ($option_authority eq 'remote') {
+            # Try authority remotely given.
+            # Note: Several proxies set "X-Forwarded-Host:" and/or
+            # "X-Forwarded-Server:" fields.  Some of them (e.g. AWS load
+            # balancer) additionally set "X-Forwarded-Port:" field.
+            if ($host_port = $ENV{HTTP_X_FORWARDED_HOST}) {
+                $host_port = [split /\s*,\s*/, $host_port]->[0];
+            } elsif ($host_port = $ENV{HTTP_X_FORWARDED_SERVER}) {
+                $host_port = [split /\s*,\s*/, $host_port]->[0];
+                $port = $ENV{HTTP_X_FORWARDED_PORT};
+            }
+        } else {    # 'local'
+            if (my $path = $ENV{SCRIPT_NAME}) {
+                $uri->path($path);
+            }
+        }
+
+        unless ($host_port) {
+            # Try authority locally given.
+            if ($host_port = $ENV{HTTP_HOST}) {
+                ;
+            } else {
+                # HTTP/1.0 or earlier?
+                $host_port = $ENV{SERVER_NAME};
+                $port      = $ENV{SERVER_PORT};
+            }
+        }
+
+        if ($host_port) {
+            if ($host_port !~ /[^:0-9a-f]/i and $host_port =~ /:.*:/) {
+                # IPv6 address not enclosed.
+                $host_port = "[$host_port]";
+            }
+            unless ($host_port =~ /:\d+\z/) {
+                $host_port .= ':'
+                    . ($port ? $port : ($uri->scheme eq 'https') ? 443 : 80);
+            }
+            $uri->host_port($host_port);
+        }
+
+        $base = $uri->canonical->as_string;
+    } elsif ($option_authority eq 'omit') {
+        $base =
+            URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url'))->path;
+    } else {    # 'default'
+        $base = Conf::get_robot_conf($robot_id, 'wwsympa_url');
+    }
+
+    $base .= '/nomenu' if $options{nomenu};
+    $base .= '/' . $action if defined $action and length $action;
+
+    if (ref $that eq 'Sympa::List') {
+        return Sympa::Tools::Text::weburl($base,
+            [$that->{'name'}, @{$options{paths} || []}], %options);
+    } else {
+        return Sympa::Tools::Text::weburl($base, $options{paths}, %options);
+    }
+}
+
+=over
+
 =item is_listmaster ( $that, $who )
 
 Is the user listmaster?

src/lib/Sympa/Tools/Text.pm

@@ -247,22 +247,35 @@ sub mailtourl {
         $utext  = Sympa::Tools::Text::encode_uri($dtext, omit => '@');
         $qsep   = '?';
     }
+    my $qstring = _url_query_string(
+        $options{query},
+        decode_html => $options{decode_html},
+        leadchar    => $qsep,
+        sepchar     => '&',
+        trim_values => 1,
+    );
+
+    return sprintf $format, $utext, $qstring;
+}
+
+sub _url_query_string {
+    my $query   = shift;
+    my %options = @_;
 
-    my $qstring;
-    my $query = $options{query};
     unless (ref $query eq 'HASH' and %$query) {
-        $qstring = '';
+        return '';
     } else {
-        $qstring = $qsep . join(
-            '&',
+        my $decode_html = $options{decode_html};
+        my $trim_values = $options{trim_values};
+        return ($options{leadchar} || '?') . join(
+            ($options{sepchar} || ';'),
             map {
                 my ($dkey, $dval) = map {
-                    (not defined $_) ? ''
-                        : $options{decode_html}
-                        ? Sympa::Tools::Text::decode_html($_)
-                        : $_;
+                          (not defined $_) ? ''
+                        : $decode_html ? Sympa::Tools::Text::decode_html($_)
+                        :                $_;
                 } ($_, $query->{$_});
-                unless (lc $dkey eq 'body') {
+                if ($trim_values and lc $dkey ne 'body') {
                     $dval =~ s/\A\s+//;
                     $dval =~ s/\s+\z//;
                     $dval =~ s/(?:\r\n|\r|\n)(?=[ \t])//g;
@@ -275,8 +288,6 @@ sub mailtourl {
                 } sort keys %$query
         );
     }
-
-    return sprintf $format, $utext, $qstring;
 }
 
 # Old name: tools::qdecode_filename().
@@ -353,6 +364,42 @@ sub valid_email {
     return 1;
 }
 
+sub weburl {
+    my $base    = shift;
+    my $paths   = shift;
+    my %options = @_;
+
+    my @paths = map {
+        Sympa::Tools::Text::encode_uri(
+              (not defined $_)      ? ''
+            : $options{decode_html} ? Sympa::Tools::Text::decode_html($_)
+            : $_
+        );
+    } @{$paths || []};
+
+    my $qstring = _url_query_string(
+        $options{query},
+        decode_html => $options{decode_html},
+        sepchar     => '&',
+    );
+
+    my $fstring;
+    my $fragment = $options{fragment};
+    if (defined $fragment) {
+        $fstring = '#'
+            . Sympa::Tools::Text::encode_uri(
+            $options{decode_html}
+            ? Sympa::Tools::Text::decode_html($fragment)
+            : $fragment
+            );
+    } else {
+        $fstring = '';
+    }
+
+    return sprintf '%s%s%s', join('/', grep { defined $_ } ($base, @paths)),
+        $qstring, $fstring;
+}
+
 1;
 __END__
 
@@ -587,6 +634,43 @@ L</decode_filesystem_safe>.
 
 Basic check of an email address.
 
+=item weburl ( $base, \@paths, [ decode_html =E<gt> 1 ],
+[ fragment =E<gt> $fragment ], [ query =E<gt> \%query ] )
+
+Constructs a C<http:> or C<https:> URL under given base URI.
+
+Parameters:
+
+=over
+
+=item $base
+
+Base URI.
+
+=item \@paths
+
+Additional path components.
+
+=item decode_html =E<gt> 1
+
+If set, arguments are assumed to include HTML entities.
+Exception is $base:
+It is assumed not to include entities.
+
+=item fragment =E<gt> $fragment
+
+Optional fragment.
+
+=item query =E<gt> \%query
+
+Optional query.
+
+=back
+
+Returns:
+
+A URI.
+
 =item wrap_text ( $text, [ $init_tab, [ $subsequent_tab, [ $cols ] ] ] )
 
 I<Function>.