Skip to content

Instantly share code, notes, and snippets.

@dancingfrog

dancingfrog/www.pl

Last active August 29, 2015 14:23
Show Gist options
  • Save dancingfrog/33a81ffa441050058cbf to your computer and use it in GitHub Desktop.
Save dancingfrog/33a81ffa441050058cbf to your computer and use it in GitHub Desktop.
Download ZIP
WWW-Mojo-Proxy :: Port-based mapping between domain name and http server
Raw
www.pl
#!/usr/bin/env perl
use warnings;
use strict;
use 5.10.1;
use Mojolicious::Lite;
use Mojo::UserAgent;
use Mojo::Log;
use Encode qw{encode};
# www-mojo-proxy server:
# Name-to-Port-based mapping between the url and http server
# This array of domains and the subsequent set of related
# hashes indicate which ports, domain-suffixes, and window
# titles should be associated with which domain names
my @domains = (
'uni-sol',
'global-survival'
);
my %ports = (
'uni-sol' => ':9090',
'global-survival' => ':9099'
);
my %top_level = (
'uni-sol' => '.org',
'global-survival' => '.org'
);
my %titles = (
'uni-sol' => "Uni::Sol",
'global-survival' => "Global-Survival/GSs"
);
our $version = Mojolicious->VERSION;
# The hypnotoad port I use, which relies on a system route to redirect
# users who connect to port 80, so I don't have to run hypnotoad as root
#app->config( hypnotoad => {listen=>['http://*:9000']} );
my $sortDomains = sub {
my $c = shift;
my $log = $c->app->log;
my $base_url = $c->req->url->base;
my( $path )= $c->req->url->path =~ /([\w|\-|\.|\/]+)/;
my( $port ) = $base_url =~ /.*[\w|\-|\.]+(\:\d+)/;
( $base_url ) = $base_url =~ /(https?\:\/\/[\w|\-|\.]*)(\:\d+)?/;
$log->debug("$base_url") if( $base_url );
$log->debug("$port") if( $port );
$log->debug("$path") if( $path );
for( @domains ){
if( ($base_url) && ($base_url =~ /($_)/) ) {
$port = $ports{$_};
my $domain = $_;
my $top = $top_level{$_};
my $title = $titles{$_};
return ($c, $domain.$top, $port, $path);
}
}
};
my $parseReq = sub {
my $c = shift;
my $log = $c->app->log;
my $types = $c->app->types;
my $ua = Mojo::UserAgent->new;
my( $self, $URL, $port, $path ) = $sortDomains->($c);
my $file;
if( ($path) && ($path =~ /\/(.+[\.|\w|\-|\#]\/([\.|\w|\-|\#]+\.\w+))$/) ) {
$path = "/$1";
$file = "$2";
} elsif( ($path) && ($path =~ /\/(.+[\.|\w|\-|\#])$/) ) {
$path = "/$1/";
}
$log->debug( $path );
my $apppath = $self->req->url->base.$path;
my $abspath = "http://$URL$port$path";
my $absname = "http://$URL$port";
$log->debug("\nFetch resource: ". $abspath ."\n");
my $parseRes = sub {
#$c->ua->get("http://127.0.0.1:9090" => {Accept => '*/*'} => sub {
my( $ua, $tx ) = @_;
my $gotten = $tx->res->body;
$log->debug("\n". $abspath ."\n");
$log->debug("\n". $file ."\n") if( $file );
#$log->debug("\n". $ua ."\n");
#$log->debug("\n". $tx ."\n");
#$log->debug("\n". $tx->res ."\n");
#$log->debug("\n". $tx->res->dom ."\n");
if( $path =~ /(\.js|\.bmp|\.gif|\.jpg|\.png|\.ogg|\.ogv|.ovg|\.mp3|\.mp4|\.mpg|\.ttf|\.woff)/ ) {
if( $path =~ /.js/ ) {
# Content-Type: application/javascript
$types->type('javascript' => 'application/javascript; charset=utf-8');
#$self->render(data => "\n". $gotten ."\n", format => 'javascript');
$self->write_chunk($gotten => sub {
my $c = shift;
$c->finish("\n\n");
} );
} elsif( $1 eq ".gif" ) {
# Content-Type: image/gif
$log->debug("\nContent-type: image/gif \n");
$self->render(data => $gotten, format => 'gif');
} elsif( $1 eq ".jpg" ) {
# Content-Type: image/jpeg
$log->debug("\nContent-type: image/jpeg \n");
$self->render(data => $gotten, format => 'jpeg');
} elsif( $1 eq ".png" ) {
# Content-Type: image/png
$log->debug("\nContent-type: image/jpeg \n");
$self->render(data => $gotten, format => 'png');
}
$self->render( inline => ( "$apppath <br /> $abspath <br /> $path" ) );
} else {
my @gotten = split( "\n", $gotten );
my( $response, @rendered );
( $abspath ) = $abspath =~ /(.+)$file/ if( defined($file) );
if( $path =~ /\.svg/ ) {
# Content-Type: image/svg+xml
$log->debug("\nContent-type: image/svg+xml \n");
$self->res->headers->content_type('image/svg+xml');
} else {
# Content-Type: text/html
$log->debug("\nContent-type: text/html \n");
$self->res->headers->content_type('text/html');
#$self->res->headers->content_type('text/plain');
}
for my $fline ( @gotten ) {
my $line_change = 1;
while( $line_change ) {
# Make sure that linked resources use absolute URIs
if( ($fline =~ /(<a)/) and ($fline =~ /(href=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:|\#)+)(\'?)(\"?)/) ) {
my $resname = $4 if( $4 );
$line_change++;
$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /(\.|http|javascript|mailto|\/\/)/ ) {
if( $resname =~ /^\/(.+)/ ) {
my $relname = $1;
$fline =~ s/$resname/$apppath$relname/g;
} else {
$fline =~ s/$resname/$apppath$resname/g;
#$line_change--;
}
} else {
$fline =~ s/$abspath$resname/$apppath$resname/g;
$line_change--;
}
$log->debug("\n". $fline ."\n");
#$fline .= "\n <!--$apppath <br /> $abspath <br /> $absname <br /> $path--> \n";
$response = $fline;
}
if( ($fline =~ /(<link)/) and ($fline =~ /stylesheet/) and ($fline =~ /<link.+(href=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)/) ) {
my $resname = $4 if( $4 );
$line_change++;
#$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /(http|javascript|mailto|\/\/)/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline."\n");
} else {
$line_change--;
}
$response = $fline;
}
if( ($fline =~ /(<script)/) and ($fline =~ /<script.+(src=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)/) ) {
my $resname = $4 if( $4 );
$line_change++;
#$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /(http|javascript|mailto|\/\/)/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline."\n");
} else {
$line_change--;
}
$response = $fline;
}
if( ($fline =~ /(<iframe)/) and ($fline =~ /<iframe.+(src=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)/) ) {
my $resname = $4 if( $4 );
$line_change++;
#$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /http/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline ."\n");
} else {
$line_change--;
}
$response = $fline;
}
if( ($fline =~ /(<img)/s) and ($fline =~ /<img.+(src=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)/) ){
my $resname = $4 if( $4 );
$line_change++;
#$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /http/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline ."\n");
} else {
$line_change--;
}
$response = $fline;
}
if( ($fline =~ /(<source)/s) and ($fline =~ /(src=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)(.+)/) ){
my $resname = $4 if( $4 );
my $cont = $8 if( $8 );
$line_change++;
$log->debug("\n". "<!--Resource $resname -->\n");
if( $cont and ($cont =~ /(src=){1}(\'?)(\"?)((\w|\-|\_|\/|\.|\:)+)(\'?)(\"?)(.+)/) ) {
my $resname = $4 if( $4 );
$line_change++;
$log->debug("\n". "<!--Resource $resname -->\n");
unless( $resname =~ /http/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline."\n");
} else {
$line_change--;
}
}
unless( $resname =~ /http/ ) {
if( $resname =~ /^\/(.+)/ ) {
$fline =~ s/$resname/$absname$resname/g;
} else {
$fline =~ s/$resname/$abspath$resname/g;
}
#$log->debug("\n". $fline."\n");
} else {
$line_change--;
}
$response = $fline;
}
$response = $fline;
$line_change--;
}
$log->debug("$response\n");
@rendered = (@rendered, "$response\n"); #eq: push @rendered, $response;
# $self->res->content->write("$response\n");
}
$response = ( join "\n", @rendered );
$response = encode("UTF-8", $response, 1);
# $log->debug( $response );
$self->res->body("$response\n");
# if( $path =~ /\.svg/ ) {
# # Content-Type: xml+svg
# $self->render(text => $response, format => 'svg');
# } elsif( $path =~ /\.html/ ) {
# # Content-Type: text/html
# $self->render(text => $response, format => 'html');
# } else {
# $self->render(inline => $response);
# }
$self->rendered(200);
}
};
$c->ua->get("$abspath" => {Accept => '*/*'} => $parseRes );
};
sub getFrame {
my( $self, $URL, $port, $path, $title ) = @_;
$self->stash( url => "$URL$port$path" );
$self->stash( title => $title );
$self->render('iframe');
}
#hook( before_dispatch => $sortDomains );
get '/' => $parseReq;
get '/:p1' => $parseReq;
get '/:p1/:p2' => $parseReq;
get '/:p1/:p2/:p3' => $parseReq;
get '/:p1/:p2/:p3/:p4' => $parseReq;
get '/:p1/:p2/:p3/:p4/:p5' => $parseReq;
get '/:p1/:p2/:p3/:p4/:p5/:p6' => $parseReq;
get '/:p1/:p2/:p3/:p4/:p5/:p6/:p7' => $parseReq;
get '/:p1/:p2/:p3/:p4/:p5/:p6/:p7/:p8' => $parseReq;
get '/:p1/:p2/:p3/:p4/:p5/:p6/:p7/:p8/:p9' => $parseReq;
get( '/favicon.ico' => sub {
my $self = shift;
# $self->reply->static('...favicon.ico');
} );
# Make sure you change this to a personal password when
# launching a live production site AND DO NOT GIT COMMIT
# changes with your personal password showing (
# hint: store your pass in a file outside the source tree,
# like /home/secret/private/auth/p@$$w0rd.pl or something )
#
app->secrets('p@$$w0rd');
app->start;
__DATA__
@@ iframe.html.ep
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd" >
<html xmlns="http://www.w3.org/1999/xhtml" style="margin-top:0;padding-top:0;height:99%;"><head>
<title><%= $title %></title>
<meta http-equiv="content-type" content="text/html; charset=utf-8" />
<meta http-equiv="Pragma" content="no-cache">
<meta name="viewport" content="width=1024,user-scalable=no" />
</head>
<body style="margin-top:0;padding-top:0;height:100%;background-color:black;overflow:hidden;">
<!--h1 style="color:#fff"><%= $url %></h1-->
<iframe
frameborder="0" marginwidth="0" width="100%" height="100%"
style="width:100%;height:100%;overflow:hidden;"
src="<%= $url %>" ></iframe>
</body></html>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment