Perl Session Handling

Overview

This document shows how to use Perl for managing state using two cookies.

Example Perl


################################################################################
# Code excerpts showing the use of two types of cookies to maintain an
# authentication session that lasts for a specified time period or until the
# browser is terminated, whichever comes first.
#
# User authentication is based on the presence of both cookies.  Only if
# neither cookie exists is CAS consulted for ticket validation (or issuance).
#
# The uid is contained in the 'persistent' cookie (the one with an expiry),
# which is encrypted in a symmetric key (to prevent user tampering).
#
# Mike Friedman
 
################################################################################
$CAS_keyfile = "...";
$CAS_cookie_expiry = "+10m";
$CAS_cookie_secure = "1";
chomp($thisprog = `basename $0`);
 
my $query = new CGI;
 
$thishost = $query->virtual_host();
 
# Define the cookie domain as our full hostname:
$CAS_thisDomain = $query->virtual_host();
 
# Define the cookie path:
$CAS_thisPath = "/cgi-bin/" "$thisprog";
 
# Create cookie name by removing file extension from App program name:
($CAS_cookieNamePersistent) = split(/\./,$thisprog);
$CAS_cookieNameNonPersistent = "$CAS_cookieNamePersistent" "N";
 
# Get the cookie encryption key:
open(KEYFILE,"<$CAS_keyfile");
chomp($CAS_key = );
close(KEYFILE);
 
# Get the user's UID, either from an existing valid cookie, or else from CAS:
 
$uid = &GetUIDFromCookie($CAS_cookieNamePersistent,"$CAS_key")
   if ( $query->cookie(-name=>$CAS_cookieNameNonPersistent) );
 
# If successful (i.e., both cookies were found), we won't send a new cookie:
if ($uid =~ /^\d+$/) {
   $CAS_cookie_persistent = "";
   $CAS_cookie_non_persistent = "";
   }
# Otherwise, check with CAS:
else {
   $uid = &GetUIDFromCAS($action,$casService);
   # If successful, set a new cookie:
   if ($uid =~ /^\d+$/) {
      # Construct persistent cookie containing UID:
      $CAS_cookie_persistent =
         &ConstructSessionCookie($CAS_cookieNamePersistent,$uid,$CAS_key,
         $CAS_cookie_expiry,$CAS_thisDomain,$CAS_thisPath,$CAS_cookie_secure);
      # Construct non-persistent cookie:
      $CAS_cookie_non_persistent = $query->cookie(
         -name     =>  "$CAS_cookieNameNonPersistent" ,
         -value    =>  "1" ,
         -domain   =>  "$CAS_thisDomain" ,
         -path     =>  "$CAS_thisPath" ,
         -secure   =>  "$CAS_cookie_secure" ,
         );
      # Set up cookie array:
      @CAS_cookies = ($CAS_cookie_persistent,$CAS_cookie_non_persistent);
      }
   }
----------------------------------------------------------------
 
# Both cookies are included in the cgi header when the page is displayed, e.g.,
 
   print $query->header(-cookie=>[@CAS_cookies]);
################################################################################
sub ConstructSessionCookie {
   # Build the contents of a cookie to send to the browser
 
   my ($name,$uid,$key,$expires,$domain,$path,$secure) = @_;
 
   my $query = new CGI;
   my $SessionID;
   my $cookie;
 
   # Make session ID out of encrypted UID:
   $SessionID = &EncryptString("$key$uid",$key);
 
   # Construct the cookie:
   $cookie = $query->cookie(
      -name     =>  "$name" ,
      -value    =>  "$SessionID" ,
      -expires  =>  "$expires" ,
      -domain   =>  "$domain" ,
      -path     =>  "$path" ,
      -secure   =>  "$secure" ,
      );
 
   return "$cookie";
   }
################################################################################
sub GetUIDFromCookie {
   # Retrieve the UID contained in a cookie originally sent from here
 
   my ($name,$key) = @_;
 
   my $query = new CGI;
 
   my $s;    # SessionID in cookie
   my $u;    # UID obtained from cookie
   my $qkey; # Meta-quoted $key for use in regexp
 
   # Retrieve the value of the 'sessionID' cookie:
   $s = $query->cookie(-name=>$name);
   return "" unless ($s);
 
   $s = &DecryptString("$s",$key);
 
   # If the session ID is valid, then the UID immediately follows the key,
   # which is the first part of the value:
   $qkey = quotemeta $key;
   $u = "$1" if ($s =~ /^$qkey(.+)$/);
 
   return "$u";
   }
################################################################################
sub GetUIDFromCAS {
   # Return the UID as obtained from CAS, either by validating an existing
   # ticket, or by referring the user to CAS for new ticket.  In the latter
   case, the UID will be obtained by validating the ticket that is returned
   # here by CAS.
 
   use strict;
 
   use LWP::UserAgent;
   use CGI;
 
   my ($thisService,$casService) = @_;
 
   my $query = new CGI;
   my $ua = LWP::UserAgent->new;
 
   my $casGet;
   my $casTicket;
   my $response;
   my $uid;
 
   # Retrieve the CAS ticket, if any, from the incoming URI:
   $casTicket = $query->url_param('ticket');
 
   # If there is a ticket, validate it with CAS, returning the user's UID:
   if ($casTicket) {
      # Construct the full URL of the CAS validation service:
      $casGet =
         "$casService\/serviceValidate?ticket=$casTicket&service=$thisService";
      # Retrieve the validation output from CAS:
      $response = $ua->get($casGet);
      # Peel off the UID from the response:
      if ($response->content =~ /(\d+)<\/cas:user>/) {
         $uid = "$1";
         }
      # If there's no uid, then retrieve the entire response (which should
      # include an error message) and return that to the caller instead of
      # a uid.
      else {
         $uid = "casTicket:  $casTicket; " . $response->content;
         }
      }
 
   # If a valid ticket was not part of the query string, redirect the user's
   # browser to CAS to get a fresh ticket:
   else {
      print
         $query->redirect(-location=>"$casService/login?service=$thisService");
      }
 
   # Return the UID (or else the error response) obtained from CAS:
   return $uid;
   }
################################################################################
sub EncryptString {
   # Encrypt plaintext and return the Base64 encoding of the cyphertext
 
   use Crypt::CBC;
   use MIME::Base64;
 
   my ($plaintext,$key) = @_;
 
   my $CBCAlgorithm = "Blowfish";
   my $ciphertext;
   my $cipher;
 
   $cipher = Crypt::CBC->new(
      -key      => $key ,
      -cipher   => $CBCAlgorithm ,
      -salt     => 1 ,
      );
 
   $ciphertext = encode_base64($cipher->encrypt($plaintext),"");
 
   return($ciphertext);
   }
################################################################################
sub DecryptString {
   # Decode Base64 cyphertext and then decrypt it, returning the plaintext
 
   use Crypt::CBC;
   use MIME::Base64;
 
   my ($ciphertext,$key) = @_;
 
   my $CBCAlgorithm = "Blowfish";
   my $plaintext;
   my $cipher;
 
   $cipher = Crypt::CBC->new(
      -key      => $key ,
      -cipher   => $CBCAlgorithm ,
      -salt     => 1 ,
      );
 
   $plaintext = $cipher->decrypt(decode_base64($ciphertext));
 
   return($plaintext);
   }