Changeset 219

Show
Ignore:
Timestamp:
10/03/06 22:22:28 (2 years ago)
Author:
jwalt
Message:
  • added demo: webshell
  • added ability to define own console commands in plugins
  • changed hook_xmlresponse so that $input will always be sent if you modify it, even if DECLINED is returned
  • added development plugin, continuously reloading stylesheets
Files:

Legend:

Unmodified
Added
Removed
Modified
Copied
Moved

  • trunk/MANIFEST

    r214 r219  
    6565demo/webmail/main.tal 
    6666demo/webmail/xmlmail-display.xsl 
     67demo/webshell/webshell.css 
     68demo/webshell/webshell.xsl 
    6769demo/xpathscript/demo.xps 
    6870demo/xpathscript/index.xml 
    …… 
    128130plugins/demo/serve_xsp 
    129131plugins/demo/webmail 
     132plugins/demo/webshell 
     133plugins/development 
    130134plugins/dir_to_xml 
    131135plugins/error_xml 

  • trunk/axkit

    r103 r219  
    2222$::DEBUG = 0; 
    2323my $configfile = './etc/axkit.conf'; 
     24my $test = 0; 
    2425 
    2526Getopt::Long::GetOptions( 
    26                          'd|debug+'      => \$::DEBUG, 
     27                         'd|debug+'      => \$::DEBUG, 
    2728                         'c|configfile=s' => \$configfile, 
     29                         't|test+'         => \$test, 
    2830                         ); 
    2931 
    30 AxKit2->run($configfile); 
     32AxKit2->run($configfile,$test); 

  • trunk/etc/axkit.conf.sample

    r205 r219  
    138138#     </Location> 
    139139 
     140# WebShell DEMO 
     141# Note that this may pose a security risk, so only enable this if you 
     142# plan to actually use/test it, and ensure you have set up decent passwords 
     143#     <Location /webshell> 
     144#        DocumentRoot demo/webshell 
     145#        Plugin authenticate 
     146#        AuthType Digest 
     147#        AuthFile etc/passwd 
     148# 
     149#        Plugin demo/webshell 
     150#    </Location> 
     151 
    140152</Server> 

  • trunk/lib/AxKit2.pm

    r205 r219  
    3333    my $class       = shift; 
    3434    my $configfile  = shift; 
     35    my $test        = shift; 
    3536     
    3637    my $config = AxKit2::Config->new($configfile); 
     38    exit(0) if $test; 
    3739     
    3840    local $SIG{'PIPE'} = "IGNORE";  # handled manually 

  • trunk/lib/AxKit2/Client.pm

    r216 r219  
    182182    my @rc = $self->run_hooks('message', @_); 
    183183    $self->log(LOGWARN,"Unhandled message: $_[0]") if shift(@rc) != OK; 
    184     return @_ if wantarray; 
    185     return $_[0]; 
     184    return @rc if wantarray; 
     185    return $rc[0]; 
    186186} 
    187187 
    …… 
    360360sub hook_xmlresponse_end { 
    361361    my ($self, $ret, $out, $input, $hd) = @_; 
     362    $out ||= $input, $ret = OK if $input->was_used; 
    362363    if ($ret == DECLINED) { 
    363364        return $self->run_hooks('response', $hd); 

  • trunk/lib/AxKit2/Config.pm

    r214 r219  
    375375    my ($package, $symbol, $referent, $attr, $data, $phase) = @_; 
    376376 
    377     if ($symbol eq 'ANON') { # yuck. eval'ed sub names sometimes don't find their way here, so we work around. 
    378         no strict 'refs'; 
    379         foreach my $key (keys %{*{$package."::"}}) { 
    380             my $sub = $package->can($key); 
    381             # tricky logic: either $package->can() is our referent, or (probably due to the same bug/feature) 
    382             # $package->can() is undefined but a symbol table entry exists. 
    383             next unless $key =~ m/^conf_/ && ($sub? $sub eq $referent : *{$package."::".$key}); 
    384             $symbol = \*{$package."::".$key}; 
    385             last; 
    386         } 
    387     } 
     377    AxKit2::Utils::_attribute_symbol($package, $symbol, $referent, qr(^conf_)); 
     378 
    388379    ref($symbol) or _die "Attribute '${attr}' on invalid symbol $symbol in package $package"; 
    389380    my $name = *{$symbol}; 

  • trunk/lib/AxKit2/Console.pm

    r205 r219  
    126126} 
    127127 
     128my %helptext; 
     129my @packages; 
     130 
     131sub import { 
     132    my $package = caller; 
     133    no strict 'refs'; 
     134    push @{$package.'::ISA'}, 'AxKit2::Console::Attributes'; 
     135    push @packages, $package; 
     136} 
     137 
    128138sub process_line { 
    129139    my AxKit2::Console $self = shift; 
    …… 
    132142    $line =~ s/\r?\n//; 
    133143    my ($cmd, @params) = split(/ +/, $line); 
    134     my $meth = "cmd_" . lc($cmd); 
     144    my $meth = "console_" . lc($cmd); 
    135145    if (my $lookup = $self->can($meth)) { 
    136146        $lookup->($self, @params); 
    …… 
    138148    } 
    139149    else { 
     150        foreach my $package (@packages) { 
     151            no strict 'refs'; 
     152            if (my $lookup = $package->can($meth)) { 
     153                $lookup->($self, @params); 
     154                return $self->write($PROMPT); 
     155            } 
     156        } 
    140157        # No such method - i.e. unrecognized command 
    141158        return $self->write("command '$cmd' unrecognised\n$PROMPT"); 
    …… 
    143160} 
    144161 
    145 my %helptext; 
    146  
    147162$helptext{help} = "HELP [CMD] - Get help on all commands or a specific command"; 
    148163 
    149 sub cmd_help { 
     164sub console_help { 
    150165    my $self = shift; 
    151166    my ($subcmd) = @_; 
    …… 
    163178 
    164179$helptext{quit} = "QUIT - Exit the console"; 
    165 sub cmd_quit { 
     180sub console_quit { 
    166181    my $self = shift; 
    167182    $self->close; 
    …… 
    169184 
    170185$helptext{list} = "LIST [LIMIT] - List current connections, specify limit or negative limit to shrink list"; 
    171 sub cmd_list { 
     186sub console_list { 
    172187    my $self = shift; 
    173188    my ($count) = @_; 
    …… 
    202217 
    203218$helptext{kill} = "KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF"; 
    204 sub cmd_kill { 
     219sub console_kill { 
    205220    my $self = shift; 
    206221    my ($match) = @_; 
    …… 
    214229    foreach my $fd (keys %$descriptors) { 
    215230        my $pob = $descriptors->{$fd}; 
    216         if ($pob->isa("Qpsmtpd::PollServer")) { 
     231        if ($pob->isa("AxKit2::Connection")) { 
    217232            if ($is_ip) { 
    218233                next unless $pob->connection->remote_ip; # haven't even started yet 
    …… 
    238253 
    239254$helptext{dump} = "DUMP \$REF - Dump a connection using Data::Dumper"; 
    240 sub cmd_dump { 
     255sub console_dump { 
    241256    my $self = shift; 
    242257    my ($ref) = @_; 
    …… 
    262277 
    263278$helptext{leaks} = "LEAKS [DUMP] - Run Devel::GC::Helper to list leaks with optional Dumper output"; 
    264 sub cmd_leaks { 
     279sub console_leaks { 
    265280    my $self = shift; 
    266281    my $dump = shift || ''; 
    …… 
    293308} 
    294309 
    295 $helptext{stats} = "STATS - Show status and statistics"; 
    296 sub cmd_stats { 
    297     my $self = shift; 
    298      
    299     my $output = "Current Status as of " . gmtime() . " GMT\n\n"; 
    300      
    301     if (defined &AxKit2::Plugin::stats::get_stats) { 
    302         # Stats plugin is loaded 
    303         $output .= AxKit2::Plugin::stats->get_stats; 
    304     } 
    305      
    306     my $descriptors = Danga::Socket->DescriptorMap; 
    307      
    308     my $current_connections = 0; 
    309     my $current_dns = 0; 
    310     foreach my $fd (keys %$descriptors) { 
    311         my $pob = $descriptors->{$fd}; 
    312         if ($pob->isa("AxKit2::Connection")) { 
    313             $current_connections++; 
    314         } 
    315     } 
    316      
    317     $output .= "Current Connections: $current_connections\n"; 
    318      
    319     $self->write($output); 
    320 } 
    321  
    322 sub cmd_shutdown { 
     310$helptext{shutdown} = 'SHUTDOWN - terminates the running server'; 
     311sub console_shutdown { 
    323312    my $self = shift; 
    324313    Danga::Socket->SetPostLoopCallback(sub { 0 }); 
    …… 
    366355} 
    367356 
     357package AxKit2::Console::Attributes; 
     358 
     359use Attribute::Handlers; 
     360 
     361sub Help : ATTR(CODE) { 
     362    my ($package, $symbol, $referent, $attr, $data, $phase) = @_; 
     363 
     364    AxKit2::Utils::_attribute_symbol($package, $symbol, $referent, qr(^console_)); 
     365 
     366    ref($symbol) or die "Attribute '${attr}' on invalid symbol $symbol in package $package"; 
     367    my $name = *{$symbol}; 
     368 
     369    $name =~ s/.*::console_// or die "Attribute '${attr}' on invalid sub $name"; 
     370    $name = lc($name); 
     371 
     372    $helptext{$name} = $data; 
     373} 
     374 
    3683751; 
    369376 
    …… 
    378385The console allows you to see and change some internal values. Connect to 
    379386localhost at the port specified in the configuration option C<< ConsolePort >> 
    380 and read the help. 
    381  
    382 Someone has to write some more details about this. 
     387and type C<HELP>. 
     388 
     389=head1 COMMANDS 
     390 
     391While plugins can add more commands, there are a few built-in commands that 
     392are always available. 
     393 
     394=head2 C<HELP> [ I<command> ] 
     395 
     396Shows a list of available commands, or help for a specific command. 
     397 
     398=head2 C<QUIT> 
     399 
     400Quits the console. 
     401 
     402=head2 C<LIST> [ I<limit> ] 
     403 
     404Lists current connections. I<limit> is the number of connections shown. 
     405If I<limit> is negative, shows entries from the beginning of the list, 
     406otherwise the latest connections are shown. 
     407 
     408=head2 C<KILL> I<address> | I<reference> 
     409 
     410Forcefully closes a connection. You can either specify an IP address, or 
     411a connection reference as shown in C<LIST> 
     412 
     413=head2 C<DUMP> I<reference> 
     414 
     415Prints a dump of a connection using Data::Dumper. 
     416 
     417=head2 C<LEAKS> [ C<DUMP> ] 
     418 
     419Run Devel::GC::Helper to list leaks. If C<DUMP> is given, also dumps 
     420the result via Data::Dumper. 
     421 
     422=head2 C<SHUTDOWN> 
     423 
     424Terminates the AxKit2 server. 
     425 
     426=head1 API 
     427 
     428To provide additional commands for the console, do something like this: 
     429 
     430    use AxKit2::Console; 
     431     
     432    $CONSOLE_HELP{mycmd} = "MYCMD - example for the docs"; 
     433    sub console_mycmd { 
     434        my $console = shift; 
     435        $console->write("You called 'MYCMD' with args: ".join(", ",@_)."\n"); 
     436        AxKit2::Client->log(LOGINFO,"MYCMD called."); 
     437    } 
    383438 
    384439=cut 

  • trunk/lib/AxKit2/HTTPHeaders.pm

    r216 r219  
    392392*uri = \&request_uri; 
    393393 
     394=head2 C<< $obj->full_uri >> 
     395 
     396Gets the request URI including host name and port. This URI can be used 
     397to build links to the currently running code, or for redirects. 
     398 
     399Please be aware that it can yield wrong results in some reverse-proxy setups. Moreover, 
     400this method works like C<< $obj->uri >> when no C<Host>-Header is present. 
     401 
     402=cut 
     403 
     404sub full_uri { 
     405    my AxKit2::HTTPHeaders $self = shift; 
     406    # FIXME: handle HTTP/0.9 requests, allow configurable prefix for reverse-proxy situations, 
     407    # using something like Apache's ServerName directive. 
     408    return $self->request_uri if !$self->header('Host'); 
     409    return "http://".$self->header('Host').$self->request_uri; 
     410} 
     411 
    394412# Parse the Cookie header. 
    395413sub parse_cookies { 

  • trunk/lib/AxKit2/Plugin.pm

    r217 r219  
    2222 
    2323use AxKit2::Constants; 
    24 use Attribute::Handlers; 
    2524 
    2625# more or less in the order they will fire 
    …… 
    121120} 
    122121 
    123  
    124 my %_HANDLER_ATTRIB; 
    125  
    126 sub Stacked : ATTR(CODE) { 
    127     my ($package, $symbol, $referent) = @_; 
    128     $_HANDLER_ATTRIB{$referent} = 1; 
    129 } 
    130  
    131122sub dispatch_message { 
    132123    my $self = shift; 
    133124    my $message = shift; 
     125    $message =~ s/-/_/g; 
    134126    if (my $sub = $self->can("message_$message")) { 
    135         $sub->($self,@_), return DECLINED if ($_HANDLER_ATTRIB{$sub}); 
    136         return OK, $sub->($self,@_); 
     127        my @rc = $sub->($self,@_); 
     128        return DECLINED if (!@rc); 
     129        return OK, @rc; 
    137130    } 
    138131    return DECLINED; 
    …… 
    332325 
    333326By default, the first message handler that is found is run and it's return value returned. 
    334 If you want your handler to stack, i.e., that other handlers are run after it, specify the 
    335 attribute C<Stacked> on the sub: 
    336  
    337   sub message_login : Stacked { 
    338     my ($self, $user) = @_; 
    339     # log it somewhere special, but do not interfere with regular login processing. 
    340     open(my $fh, '>>', 'userlog'); print $fh time()." ".$user."\n"; close($fh); 
    341   } 
    342  
    343 Of course, the return value of stacked handlers is ignored. 
     327If you want that other handlers are run after it, return an empty list C<< () >>. 
    344328 
    345329If you need even more complex processing, see C<< hook_handler >> below. 

  • trunk/lib/AxKit2/Processor.pm

    r169 r219  
    6363sub dom { 
    6464    my $self = shift; 
     65    @_ and $self->{used} = 1; 
    6566    @_ and $self->{input} = shift; 
    6667     
    …… 
    8283        return $self->{input} = $parser->parse_string($input); 
    8384    } 
     85} 
     86 
     87# Has this object been used by user code? 
     88sub was_used { 
     89    my $self = shift; 
     90    return $self->{used}; 
    8491} 
    8592 
    …… 
    121128        if ($AxKit2::Processor::DumpIntermediate) { 
    122129            mkdir("/tmp/axtrace"); 
    123             open(my $fh, ">/tmp/axtrace/trace.$pos"); 
     130            open(my $fh, ">:raw", "/tmp/axtrace/trace.$pos"); 
    124131            print $fh ($dom || $self->dom)->toString; 
    125132        } 
    …… 
    129136    } 
    130137     
    131     return $self->new($self->client, $self->path, $dom, $outfunc); 
     138    $self->{output} = $outfunc; 
     139    return $self; 
    132140} 
    133141 

  • trunk/lib/AxKit2/Transformer/TAL.pm

    r169 r219  
    5353     
    5454    return $results, sub { $self->output(@_) }; 
     55} 
     56 
     57sub RELOAD { 
     58    undef %cache; 
    5559} 
    5660 

  • trunk/lib/AxKit2/Transformer/XSLT.pm

    r169 r219  
    6262} 
    6363 
     64sub RELOAD { 
     65    undef %cache; 
     66} 
     67 
    6468sub fixup_params { 
    6569    my @results; 

  • trunk/lib/AxKit2/Utils.pm

    r169 r219  
    2727    xml_escape 
    2828    bytelength 
     29    html_to_dom 
    2930    ); 
    3031 
    …… 
    121122} 
    122123 
     124use XML::LibXML; 
     125my $parser = new XML::LibXML(); 
     126$parser->expand_xinclude(0); 
     127 
     128sub html_to_dom { 
     129    my $dom = $parser->parse_html_string(shift); 
     130    $dom->setEncoding('UTF-8'); 
     131    return $dom; 
     132} 
     133 
     134# It looks as if eval'ed sub names sometimes don't find their way into attribute handlers, so we work around. 
     135sub _attribute_symbol { 
     136    my ($package, $symbol, $referent, $match) = @_; 
     137    if ($symbol eq 'ANON') {  
     138        no strict 'refs'; 
     139        foreach my $key (keys %{*{$package."::"}}) { 
     140            my $sub = $package->can($key); 
     141            # tricky logic: either $package->can() is our referent, or (probably due to the same bug/feature) 
     142            # $package->can() is undefined but a symbol table entry exists. 
     143            next unless $key =~ m/$match/ && ($sub? $sub eq $referent : *{$package."::".$key}); 
     144            $symbol = \*{$package."::".$key}; 
     145            last; 
     146        } 
     147    } 
     148    $_[1] = $symbol; 
     149} 
     150 
    1231511; 

  • trunk/plugins/authenticate

    r218 r219  
    129129If you use Digest authentication, you also gain a free session ID for all 
    130130authenticated users without needing cookies or URL parameters. It is generated 
    131 at login and can be retrieved through C<< $client->headers_in->header('Digest-Session') >>. 
     131at login and can be retrieved through C<< $plugin->send('session-id') >>. 
    132132If you use that mechanism, you can even log out users using the logout function. 
    133133 
    …… 
    274274pages will result in a new login prompt. 
    275275 
     276=head2 C<< session-id >> 
     277 
     278Returns the current session id, if any. 
     279 
    276280=head1 MESSAGES SENT 
    277281 
    278 =head2 C<< login >> 
     282=head2 C<< login I<username>, I<session-id> >> 
    279283 
    280284This message is sent when a user successfully starts a new login session. 
    281285 
    282 =head2 C<< login_failed >> 
     286=head2 C<< login_failed I<username> >> 
    283287 
    284288This message is sent whenever a real login failure is detected. Your application code 
    …… 
    287291=cut 
    288292 
     293sub message_session_id { 
     294    my ($self) = @_; 
     295    return $self->notes('session') || (); 
     296} 
     297 
    289298sub message_logout { 
    290299    my ($self, $session) = @_; 
    291     $session = $self->client->headers_in->header('Digest-Session') unless defined $session; 
     300    $session = $self->notes('session') unless defined $session; 
    292301    return unless defined $session; 
    293302    delete $_SESSIONS{$session}; 
    …… 
    299308 
    300309    my $timestamp = time(); 
    301     if (exists $_SESSIONS{$session}) { 
     310    if (defined $session && exists $_SESSIONS{$session}) { 
    302311        $_SESSIONS{$session}[0] = 1; 
    303312        $_SESSIONS{$session}[1] = int($timestamp); 
    …… 
    305314    } else { 
    306315        undef $session; 
     316        $user = ''; 
    307317    } 
    308318 
    …… 
    324334sub send_digest_forbidden { 
    325335    my ($self, $msg) = @_; 
    326     $self->log(LOGWARN,"Invalid access! Possible hacking attempt. $msg"); 
     336    $self->log(LOGWARN,"Invalid access! Possible hacking attempt: $msg"); 
    327337    $self->client->headers_out->header_remove('Authentication-Info'); 
    328338 
    …… 
    407417            return $self->send_digest_forbidden("replay attack") if $param{qop} && $param{nc} ne sprintf("%08x",$$s[0]); 
    408418            # Timestamp invalid: replay attack. 
    409             return $self->send_digest_forbidden("invalid timestamp") if $timestamp != $$s[1]; 
     419            return $self->send_digest_forbidden("invalid timestamp $timestamp (expected ${$s}[1])") if $timestamp != $$s[1]; 
    410420            # Username mismatch: attempt to take over different user's session 
    411421            return $self->send_digest_forbidden("user mismatch in server nonce") if $param{username} ne $user; 
    …… 
    456466        # tremendous performance impact. I assume the major browsers don't check it anyway, so let it be for now.  
    457467 
    458         $hd->header('Digest-Session',$session); 
     468        $self->notes('session',$session); 
    459469        if (!defined $_SESSIONS{$session}[0]) { 
    460470            # Successful login, establish server-side state. 
    461471            $_SESSIONS{$session} = [ -1 ]; 
    462             $self->send('login',$param{username}); 
     472            $self->send('login',$param{username},$session); 
    463473            # Need another round-trip, since we want to tie the session id to the user name but avoid extra server-side state. 
    464474            return $self->send_digest_challenge($session,$param{username}); 
    …… 
    469479            # Change nonce once per minute to reduce replay attack time window. 
    470480            return $self->send_digest_challenge($session,$param{username}) if $timestamp < time()-60; 
    471             $self->log(LOGINFO, "Identified user as $param{username} via Digest"); 
     481            $self->log(LOGINFO, "Identified user as $param{username} (session ".unpack('H*',$self->notes('session')).") via Digest"); 
    472482            return OK; 
    473483        } 

  • trunk/plugins/demo/moewiki

    r200 r219  
    2525=cut 
    2626 
    27 use XML::LibXML; 
    28 my $parser = new XML::LibXML(); 
    29 $parser->expand_xinclude(0); 
     27use AxKit2::Utils qw(html_to_dom); 
    3028 
    3129sub hook_xmlresponse { 
    …… 
    4240        $input->dom("<html><body>\nThis page has just been created.\n</body></html>"); 
    4341    } elsif ($client->param('text')) { 
    44         my $dom = $parser->parse_html_string($client->param('text')); 
    45         $dom->setEncoding('UTF-8'); 
     42        my $dom = html_to_dom($client->param('text')); 
    4643        open(FH,'>:utf8',$file.'.xml'); 
    4744        print FH $dom->toStringC14N(); 
    4845        close(FH); 
    49         my $uri = $client->headers_in->request_uri; 
     46        my $uri = $client->headers_in->full_uri; 
    5047        $uri =~ s/\?.*$//; 
    51         warn("URI: $uri"); 
    52         $self->client->headers_out->header('Location', "http://".$client->headers_in->header('Host').$uri); 
     48        $self->client->headers_out->header('Location', $uri); 
    5349        return REDIRECT; 
    5450    } 

  • trunk/plugins/stats

    r103 r219  
    3333 
    3434This module provides statistics on the server since it was last restarted. 
     35It adds the console command C<STATS>. 
    3536 
    3637The following stats are provided: 
    …… 
    6364 
    6465use Time::HiRes qw(time); 
     66use AxKit2::Console; 
    6567 
    6668our $START_TIME = time; 
    …… 
    6971our $ERRS = 0; 
    7072 
    71 sub get_stats { 
    72     my $class = shift; 
    73     my $uptime = $class->uptime; 
    74     my ($rate, $unit) = $class->delivery_rate; 
    75     return sprintf("           Uptime: %s\n". 
    76                    "   Total Requests: % 10d\n". 
    77                    "      OK Requests: % 10d\n". 
    78                    "           Errors: % 10d\n". 
    79                    "    Delivery Rate: %0.2f reqs/%s\n\n", 
    80                    $uptime, $REQS, $REQS_OK, $ERRS, $rate, $unit); 
     73sub console_stats : Help("STATS - Show status and statistics") { 
     74    my $self = shift; 
     75     
     76    my $uptime = &uptime; 
     77    my ($rate, $unit) = &delivery_rate; 
     78 
     79    my $output = "Current Status as of " . gmtime() . " GMT\n\n" .  
     80         sprintf("           Uptime: %s\n". 
     81                 "   Total Requests: % 10d\n". 
     82                 "      OK Requests: % 10d\n". 
     83                 "           Errors: % 10d\n". 
     84                 "    Delivery Rate: %0.2f reqs/%s\n\n", 
     85                 $uptime, $REQS, $REQS_OK, $ERRS, $rate, $unit); 
     86 
     87    my $descriptors = Danga::Socket->DescriptorMap; 
     88     
     89    my $current_connections = 0; 
     90    my $current_dns = 0; 
     91    foreach my $fd (keys %$descriptors) { 
     92        my $pob = $descriptors->{$fd}; 
     93        if ($pob->isa("AxKit2::Connection")) { 
     94            $current_connections++; 
     95        } 
     96    } 
     97     
     98    $output .= "Current Connections: $current_connections\n"; 
     99     
     100    $self->write($output); 
    81101} 
    82102 
    …… 
    128148 
    129149sub delivery_rate { 
    130     my $class = shift; 
    131150    my $unit = 'sec'; 
    132151    my $per_sec = ($REQS / (time() - $START_TIME)); 

  • trunk/plugins/uri_to_file

    r205 r219  
    104104    return DECLINED unless $self->client->notes('need_redirect'); 
    105105     
    106     my $uri = $self->client->headers_in->request_uri; 
     106    my $uri = $self->client->headers_in->full_uri; 
    107107     
    108108    no warnings 'uninitialized'; 
    …… 
    111111        # send redirect 
    112112        $self->log(LOGINFO, "redirect to $uri"); 
    113         $self->client->headers_out->header('Location', "http://".$self->client->headers_in->header('Host').$uri); 
     113        $self->client->headers_out->header('Location', $uri); 
    114114        return REDIRECT; 
    115115    }