From 420e69289e89656d88b551ab7e7aebda12f497b9 Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Fri, 4 Jan 2013 16:35:48 +0000 Subject: [PATCH 1/1] wip, at end of file now --- cgi-auth-hybrid.pm | 151 ++++++++++++++++++++------------------------- 1 file changed, 67 insertions(+), 84 deletions(-) diff --git a/cgi-auth-hybrid.pm b/cgi-auth-hybrid.pm index 6f88489..c5530e0 100644 --- a/cgi-auth-hybrid.pm +++ b/cgi-auth-hybrid.pm @@ -2,6 +2,7 @@ # This is part of CGI::Auth::Hybrid, a perl CGI authentication module. # Copyright (C) 2012 Ian Jackson. +# Copyright (C) 2012 Citrix. # # This program is free software: you can redistribute it and/or modify # it under the terms of the GNU Affero General Public License as published by @@ -72,13 +73,13 @@ sub get_cookie_domain ($$$) { } sub construct_cookie ($$$) { - my ($c, $r, $cookv) = @_; - return $c->cookie(-name => $r->{S}{cookie_name}, - -value => $cookv, - -path => $r->{S}{cookie_path}, - -domain => $r->_ch('get_cookie_domain'), - -expires => '+'.$r->{S}{login_timeout}.'s', - -secure => $r->{S}{encrypted_only}); + my ($r, $cookv) = @_; + return $r->{Cgi}->cookie(-name => $r->{S}{cookie_name}, + -value => $cookv, + -path => $r->{S}{cookie_path}, + -domain => $r->_ch('get_cookie_domain'), + -expires => '+'.$r->{S}{login_timeout}.'s', + -secure => $r->{S}{encrypted_only}); } sub do_redirect_cgi ($$$$) { @@ -373,7 +374,7 @@ wrapper should also store answers in the $r object for later retrieval $r->_db_revoke($parmv); return ({ Kind => 'REDIRECT-LOGGEDOUT', Message => "Logging out...", - Cookie => '', + CookieVal => '', Params => { } }); } if ($r->_ch('is_loggedout')) { @@ -382,27 +383,27 @@ wrapper should also store answers in the $r object for later retrieval die unless $parmt; return ({ Kind => 'SMALLPAGE-LOGGEDOUT', Message => "You have been logged out.", - Cookie => '', + CookieVal => '', Params => { } }); } if ($r->_ch('is_login')) { $r->_must_be_post(); return ({ Kind => 'LOGIN-STALE', Message => "Stale session; you need to log in again.", - Cookie => $r->_fresh_cookie(), + CookieVal => $r->_fresh_cookie(), Params => { } }) if $parmt eq 'n'; die unless $parmt eq 't' || $parmt eq 'y'; return ({ Kind => 'SMALLPAGE-NOCOOKIE', Message => "You do not seem to have cookies enabled. ". "You must enable cookies as we use them for login.", - Cookie => $r->_fresh_cookie(), + CookieVal => $r->_fresh_cookie(), Params => $r->_chain_params() }) if !$cookt && $parmt eq 't'; my $username = $r->_ch('login_ok'); return ({ Kind => 'LOGIN-BAD', Message => "Incorrect username/password.", - Cookie => $cookv, + CookieVal => $cookv, Params => $r->_chain_params() }) unless defined $username && length $username; $r->_db_revoke($cookv) @@ -410,7 +411,7 @@ wrapper should also store answers in the $r object for later retrieval $r->_db_record_login_ok($parmv,$username); return ({ Kind => 'REDIRECT-LOGGEDIN', Message => "Logging in...", - Cookie => $parmv, + CookieVal => $parmv, Params => $r->_chain_params() }); } if ($cookt eq 't') { @@ -429,12 +430,12 @@ wrapper should also store answers in the $r object for later retrieval if ($meth eq 'GET') { return ({ Kind => 'LOGIN-INCOMINGLINK', Message => "You need to log in again.", - Cookie => $parmv, + CookieVal => $parmv, Params => $r->_chain_params() }); } else { return ((Kind => 'LOGIN-FRESH', Message => "You need to log in again.", - Cookie => $parmv, + CookieVal => $parmv, Params => { }); } } @@ -443,7 +444,7 @@ wrapper should also store answers in the $r object for later retrieval if ($meth ne 'POST') { return ({ Kind => 'MAINPAGEONLY', Message => 'Entering via cross-site link.', - Cookie => $cookv, + CookieVal => $cookv, Params => { } }); # NB caller must then ignore params & path! # if this is too hard they can spit out a small form @@ -454,6 +455,7 @@ wrapper should also store answers in the $r object for later retrieval die unless $cookt eq 'y'; die unless $parmt eq 'y'; die unless $cookv eq $parmv; + $r->{Assoc} = $cookv; $r->{UserOK} = $cooku; return undef; } @@ -518,6 +520,38 @@ sub _db_record_login_ok ($$$) { $v, $user, time); } +sub check_divert ($) { + my ($r) = @_; + my $divert; + if (exists $r->{Divert}) { + return $r->{Divert}; + } + $dbh->do("BEGIN"); + if (!eval { + $divert = $r->_check_divert_core(); + 1; + }) { + $dbh->do("ABORT"); + die $@; + } + $r->{Divert} = $divert; + $dbh->do("COMMIT"); + return $divert; +} + +sub get_divert ($) { + my ($r) = @_; + die "unchecked" unless exists $r->{Divert}; + return $r->{Divert}; +} + +sub get_username ($) { + my ($r) = @_; + my $divert = $r->get_divert(); + return undef if $divert; + return $r->{UserOK}; +} + sub url_with_query_params ($$) { my ($r, $params) = @_; my $uri = URI->new($r->_ch('get_url')); @@ -535,7 +569,7 @@ sub check_ok ($) { return 0 if $handled; my $kind = $divert->{Kind}; - my $cookie = $divert->{Cookie}; + my $cookieval = $divert->{CookieVal}; my $params = $divert->{Params}; if ($kind =~ m/^REDIRECT-/) { @@ -550,6 +584,7 @@ sub check_ok ($) { die; } my $new_url = $r->url_with_query_params($params); + my $cookie = $r->construct_cookie($r, $cookieval); $r->_ch('do_redirect')($new_url, $cookie); return 0; } @@ -594,86 +629,31 @@ sub _fresh_cookie ($) { return $r->_random($bytes); } -UP TO HERE - -sub record_login ($$) { - my ($r,$nusername) = @_; - - - - my $dbh = $r->{Dbh}; - - $r->{U} = $nusername; - $r->{A} = $nassoc; - - $dbh->do("COMMIT"); -} - -sub _check ($) { - my ($r) = @_; - - return if exists $r->{Username}; - ($r->{Username}, $r->{Assoc}, $r->{Mutate}) = $r->_check(); - - if (defined $r->{Assoc}) { - $dbh->do("UPDATE $r->{S}{assocdb_table}". - " SET last = ?". - " WHERE associd = ?", {}, time, $nassoc); - $dbh->do("COMMIT"); - } -} - -sub logout ($) { - my ($r) = @_; - - my ($nusername, $nassoc, $nmutate) = $r->_check(); - return undef unless $nmutate; - $dbh->do("DELETE FROM $r->{S}{assocdb_table}". - " WHERE associd = ?", {}, $nassoc); - $dbh->do("COMMIT"); - return $nusername; -} - -sub check ($) { - my ($r) = @_; - $r->_check(); - return !!defined $r->{Username}; -} - sub check_mutate ($) { my ($r) = @_; - $r->check(); - return $r->{Mutate}; + die "unchecked" unless exists $r->{Divert}; + die if $r->{Divert}; + my $meth = $r->_ch('get_method'); + die "mutating non-POST" if $meth ne 'POST'; } -sub username ($) { - my ($r) = @_; - $r->check(); - return $r->{Username}; +#---------- output ---------- -sub hidden_val ($) { +sub secret_val ($) { my ($r) = @_; $r->check(); return defined $r->{Assoc} ? $r->{Assoc} : ''; } -#---------- simple wrappers ---------- - -sub hidden_hargs ($) { +sub secret_hidden_html ($) { my ($r) = @_; - return (-name => $r->{S}{param_name}, - -default => $r->hidden_val()); + return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name}, + -default => $r->secret_val()); } -sub hidden_html ($) { +sub secret_cookie ($) { my ($r) = @_; - return hidden($r->hidden_hargs()); -} - -sub cookiea_cargs ($) { - my ($r) = @_; - return (-name => $r->{S}{cookie_name}, - -value => hidden_val()); + return $r->construct_cookie($r->secret_val()); } __END__ @@ -695,7 +675,7 @@ CGI::Auth::Hybrid - web authentication optionally using cookies $authreq->check_ok() or return; blah blah blah - $authreq->mutating(); + $authreq->check_mutate(); blah blah blah =head1 USAGE PATTERN FOR FANCY APPLICATIONS @@ -710,3 +690,6 @@ CGI::Auth::Hybrid - web authentication optionally using cookies } } + blah blah blah + $authreq->check_mutate(); + blah blah blah -- 2.30.2