This example shows how to perform a HTTP redirect using Pi3Perl. Compare this with the appropriate PSP example.
# change this to add your own folder to the perl library path
sub BEGIN { push @INC, qw ( . ); }
use strict;
use Pi3;
sub execute {
my($obj) = shift;
my($pihttp) = shift;
my($iobuf) = shift;
my($r) = Pi3::PIHTTP_getDB($pihttp, &Pi3::GETDB_RESPONSE);
# Set the location header and the appropriate StatusCode (302 Found)
my($l)= "http://localhost".Pi3::PIDB_lookup($r,&Pi3::PIDBTYPE_STRING,"PathInfo",&Pi3::PIDBFLAG_NONE);
Pi3::PIDB_replace($r,&Pi3::PIDBTYPE_RFC822,"Location",$l,&Pi3::PIDBFLAG_NONE);
Pi3::HTTPUtil_doHTTPError($pihttp,&Pi3::ST_FOUND);
# Send HTTP status line and response headers
Pi3::HTTPCore_sendGeneralHeaders($pihttp);
Pi3::HTTPCore_sendEntityHeaders($pihttp, $r);
return &Pi3::PIAPI_COMPLETED;
};
This example shows how to perform a basic authentication using Pi3Perl. It includes the Base64 encoding/decoding routines.
my @Base64;
my @Plain;
sub BEGIN {
my ( $Base64 ) =
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
@Base64 = split / */, $Base64;
@Plain = (
-1, -1, -1, -1, -1, -1, -1 ,-1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, -1, -1, 63,
52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, 0, -1, -1,
-1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, -1, -1, -1, -1, -1,
-1, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, -1, -1, -1, -1, -1
);
}
use strict;
use Pi3;
# +--
# Global configuration values
# --+
my $Realm;
my $AuthFile;
# +--
# Validate a user and password from the users (password) file.
# --+
sub validUser {
my( $username ) = shift;
my( $password ) = shift;
open INP, "<$AuthFile" || return 0;
foreach( <INP> ) {
next if /^\#.*/; # skip comments
# get username, password, realms
my( $user, $pass, $realmlist ) = split( / /, $_, 3 );
if ( $user =~ $username ) {
close INP;
my( @realms ) = split( /,/, $realmlist );
for(@realms)
{ return 1 if (( $_ =~ $Realm ) && ( $pass =~ $password )); };
return 0;
};
};
close INP;
return 0;
}
# +--
# Base64 encoding
# --+
sub Base64_encode {
my( @plain ) = split / */, shift;
my( $result ) = "";
my( $len ) = @plain + 0;
my( $state ) = 1;
my( $i ) = 0;
my( $iplain );
for( ;; ) {
my( $base64 );
my( $c ) = ( $i < $len ) ? ord(@plain[$i]) : 0 ;
if ( $state =~ 1 ) {
if ( $i >= $len ) { return $result; };
$base64 = ( $c >> 2 );
$iplain = ( $c << 4 ) & 0x30;
$i++;
$state = 2;
} elsif ( $state =~ 2 ) {
$base64 = $iplain | ( $c >> 4 );
$iplain = ( $c << 2 ) & 0x3C;
$i++;
$state = 3;
} elsif ( $state =~ 3 ) {
$base64 = $iplain | ( $c >> 6 );
$iplain = $c & 0x3F;
$i++;
$state = 4;
} elsif ( $state =~ 4 ) {
$base64 = $iplain;
$state = 1;
};
$result .= @Base64[$base64 & 0x3F];
if ( $i > $len ) {
if ( $state =~ 2 )
{ return $result."==="; }
elsif ( $state =~ 3 )
{ return $result."=="; }
elsif ( $state =~ 4 )
{ return $result."="; }
};
};
return $result;
}
# +--
# Base64 decoding
# --+
sub Base64_decode {
my( $pbase64 ) = split / */, shift;
my( $ilen ) = @pbase64 + 0;
my( $estate ) = 1;
my( $idone ) = 0;
my( $i );
my( $result ) = "";
my( $ilast );
for( $i=0; $i<$ilen; $i++) {
my( $c ) = @pbase64[$i];
$_ = $c;
last if ( !/[0-9a-zA-Z]/ && !/\+/ && !/\// );
my( $iplain ) = $Plain[ord($c)];
die( "assertion failure!" ) if $iplain =~ -1;
if ( $estate =~ 1 ) {
$ilast = ( $iplain << 2 ) & 0xFC;
$estate = 2;
} elsif ( $estate =~ 2 ) {
$result = $result.chr( $ilast | ( ($iplain >> 4 ) & 0x03) );
$ilast = ( $iplain << 4 ) & 0xF0;
$estate = 4;
} elsif ( $estate =~ 4 ) {
$result = $result.chr( $ilast | ( ($iplain >> 2 ) & 0x0F) );
$ilast = ( $iplain << 6 ) & 0xC0;
$estate = 6;
} elsif ( $estate =~ 6 ) {
$result = $result.chr( $ilast | ( $iplain & 0x3F) );
$estate = 1;
};
$_ = $c;
last if /=/;
};
return $result;
};
# +--
# Initialize function to setup global variables with values from
# pi3 configuration file, i.e. password file and realm name.
#
# ** NOTE ** In this implementation all perl based handlers appear to
# share the name global namespace, so multiple perl authentication handlers
# will clobber each others global data.
# --+
sub init {
my( $obj ) = shift;
my( $db ) = Pi3::PIObject_getDB( $obj );
$Realm = Pi3::PIDB_lookup( $db, &Pi3::PIDBTYPE_RFC822, "Realm",
&Pi3::PIDBFLAG_NONE );
$AuthFile = Pi3::PIDB_lookup( $db, &Pi3::PIDBTYPE_RFC822, "AuthFile",
&Pi3::PIDBFLAG_NONE );
return &Pi3::PIAPI_COMPLETED;
}
# +--
# Function which is invoked to authenticate HTTP request using basic
# authentication. Usernames and passwords are read from a file.
# --+
sub execute {
my( $obj ) = shift;
my( $pihttp ) = shift;
my( $piiobuf ) = shift;
my($request_db ) = Pi3::PIHTTP_getDB( $pihttp, &Pi3::GETDB_REQUEST );
my($response_db ) = Pi3::PIHTTP_getDB( $pihttp, &Pi3::GETDB_RESPONSE );
# Lookup the realm set in the 'AuthenticationRealm' string variable of the response DB
$_ = "";
my( $authrealm );
$authrealm = Pi3::PIDB_lookup( $response_db, &Pi3::PIDBTYPE_STRING,
"AuthenticationRealm", &Pi3::PIDBFLAG_NONE );
$_ = $authrealm;
if ( ( length( $_ ) != 0 ) && !( $_ =~ $Realm ) ) {
# This authentication handler does not apply
return &Pi3::PIAPI_CONTINUE;
};
# Get browser authentication string from the rfc822 request header
my( $authorization ) = "";
$authorization = Pi3::PIDB_lookup( $request_db, &Pi3::PIDBTYPE_RFC822,
"Authorization", &Pi3::PIDBFLAG_NONE );
$_ = $authorization;
if ( /^Basic .*/ ) {
s/^Basic (.*)/$1/;
my( $username, $password ) = split( /:/, Base64_decode( $_ ), 2 );
if ( validUser( $username, $password) )
{ return &Pi3::PIAPI_COMPLETED; };
# Otherwise fall through to challenge the authentication.
};
# Challenge the authentication
Pi3::PIDB_replace( $response_db, &Pi3::PIDBTYPE_STRING, "AuthType",
"Basic", &Pi3::PIDBFLAG_NONE );
Pi3::PIDB_replace( $response_db, &Pi3::PIDBTYPE_RFC822,
"WWW-Authenticate", 'Basic realm="'.$Realm.'"', 0 );
# Redirect because of authentication failure
Pi3::HTTPUtil_doHTTPError( $pihttp, &Pi3::ST_UNAUTHORIZED );
return 1; # INT_REDIRECT
}
#!/usr/local/psp
<%
sub pspLoad {
$counter = 0;
return 0;
}
sub pspSetResponse {
$counter++;
return 0;
}
%>
<html><body>
<h1>PSP example</h1>
<p><b>The name of PSP script is: </b><%= $pspRequest{"Path"}; %>
<p><b>I've been invoked: </b><%= $counter; %>
<p><b>The local time is: </b><%= localtime(); %>
<p><b>Your browser is: </b><%= $pspRequest{"User-Agent"}; %>
</body></html>
#!/usr/local/psp
<%
# this may extend perl library path
BEGIN { push @INC, qw(/my/perl/libs); }
use Pi3;
sub pspSetResponse
{
$piObject = shift;
return 0;
}
%>
<html><body>
<h1>PSP example, which invokes Pi3::</h1>
<p><b>Your Pi3 platform is: </b><%= Pi3::PIPlatform_getDescription(); %>
<p><b>Your Pi3Web server is: </b><%= Pi3::HTTPCore_getServerStamp(); %>
<p><b>The Pi3Web handler is: </b><%= Pi3::PIObject_getName($piObject); %>
</body></html>
#!/usr/local/psp
<%
sub pspSetResponse
{
$pspResponse{"Location"} = "http://localhost".$pspRequest{"PathInfo"};
$pspResponseStatus = 302;
return 0;
}
%>
<html><body>
If automatic redirect doesn't work, use this <a href="<%= $pspResponse{"Location"} %>">link</a>.
</html></body>