chiark - git - ian - cgi-auth-flexible.git/blob

1 # -*- perl -*-

3 # This is part of CGI::Auth::Hybrid, a perl CGI authentication module.

6 #

7 # This program is free software: you can redistribute it and/or modify

8 # it under the terms of the GNU Affero General Public License as published by

9 # the Free Software Foundation, either version 3 of the License, or

10 # (at your option) any later version.

11 #

12 # This program is distributed in the hope that it will be useful,

13 # but WITHOUT ANY WARRANTY; without even the implied warranty of

14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the

15 # GNU Affero General Public License for more details.

16 #

17 # You should have received a copy of the GNU Affero General Public License

18 # along with this program. If not, see <http://www.gnu.org/licenses/>.

20 use strict;

21 use warnings;

23 package CGI::Auth::Hybrid;

24 require Exporter;

26 BEGIN {

27 use Exporter ();

28 our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

30 $VERSION = 1.00;

31 @ISA = qw(Exporter);

32 @EXPORT = qw();

33 %EXPORT_TAGS = ( ); # eg: TAG => [ qw!name1 name2! ],

35 @EXPORT_OK = qw(setup);

36 }

37 our @EXPORT_OK;

39 use DBI;

40 use CGI qw/escapeHTML/;

41 use Locale::gettext;

42 use URI;

43 use IO::File;

44 use Data::Dumper;

46 #---------- public utilities ----------

48 sub flatten_params ($) {

49 my ($p) = @_;

50 my @p;

51 foreach my $k (keys %$p) {

52 foreach my $v (@{ $p->{$k} }) {

53 push @p, $k, $v;

54 }

55 }

56 return @p;

57 }

59 #---------- default callbacks ----------

61 sub has_a_param ($$) {

62 my ($r,$cn) = @_;

63 foreach my $pn (@{ $r->{S}{$cn} }) {

64 return 1 if $r->_ch('get_param',$pn);

65 }

66 return 0;

67 }

69 sub get_params ($) {

70 my ($r) = @_;

71 my %p;

72 my $c = $r->{Cgi};

73 foreach my $name ($c->param()) {

74 $p{$name} = [ $c->param($name) ];

75 }

76 return \%p;

77 }

79 sub get_cookie_domain ($$$) {

80 my ($c,$r) = @_;

81 my $uri = new URI $r->_ch('get_url');

82 return $uri->host();

83 }

85 sub login_ok_password ($$) {

86 my ($c, $r) = @_;

87 my $username_params = $r->{S}{username_param_names};

88 my $username = $r->_ch('get_param',$username_params->[0]);

89 my $password = $r->_rp('password_param_name');

90 return $r->_ch('username_password_ok', $username, $password);

91 }

93 sub do_redirect_cgi ($$$$) {

94 my ($c, $r, $new_url, $cookie) = @_;

95 $r->_print($c->header($r->_cgi_header_args($cookie,

96 -status => '303 See other',

97 -location => $new_url)),

98 $r->_ch('gen_start_html',$r->_gt('Redirection')),

99 '<a href="'.escapeHTML($new_url).'">',

100 $r->_gt("If you aren't redirected, click to continue."),

101 "</a>",

102 $c->_ch('gen_end_html'));

103 }

104

105 sub gen_plain_login_form ($$) {

106 my ($c,$r, $params) = @_;

107 my @form;

108 push @form, ('<form method="POST" action="'.

109 escapeHTML($r->_ch('get_url')).'">'.

110 '<table>');

111 my $sz = 'size="'.$r->{S}{form_entry_size}.'"';

112 foreach my $up (@{ $r->{S}{username_param_names}}) {

113 push @form, ('<tr><td>',$r->_gt(ucfirst $up),'</td>',

114 '<td><input type="text" '.$sz.

115 ' name='.$up.'></td></tr>');

116 }

117 push @form, ('<tr><td>'.$r->_gt('Password'),'</td>',

118 '<td><input type="password" '.$sz.

119 ' name="'.$r->{S}{password_param_name}.'"></td></tr>');

120 push @form, ('<tr><td colspan="2">',

121 '<input type="submit"'.

122 ' name="'.$r->{S}{login_submit_name}[0].'"'.

123 ' value="'.$r->_gt('Login').'"></td></tr>',

124 '</table>');

125 foreach my $n (keys %$params) {

126 push @form, ('<input type="hidden"'.

127 ' name="'.$n.'"'.

128 ' value="'.$params->{$n}.'">');

129 }

130 push @form, ('</form>');

131 return join "\n", @form;

132 }

133

134 sub gen_login_link ($$) {

135 my ($c,$r, $params) = @_;

136 my $url = $r->url_with_query_params($params);

137 return ('<a href="'.escapeHTML($url).'">'.

138 $r->_gt('Log in again to continue.').

139 '</a>');

140 }

141

142 #---------- verifier object methods ----------

143

144 sub new_verifier {

145 my $class = shift;

146 my $verifier = {

147 S => {

148 assocdb_path => 'cah-assocs.db',

149 assocdb_dsn => undef,

150 assocdb_user => '',

151 assocdb_password => '',

152 assocdb_table => 'assocs',

153 random_source => '/dev/urandom',

154 associdlen => 128, # bits

155 login_timeout => 86400, # seconds

156 assoc_param_name => 'cah_associd',

157 cookie_name => "cah_associd",

158 password_param_name => 'password',

159 username_param_names => [qw(username)],

160 form_entry_size => 60,

161 logout_param_names => [qw(cah_logout)],

162 login_submit_name => [qw(cah_login)],

163 loggedout_param_names => [qw(cah_loggedout)],

164 promise_check_mutate => 0,

165 get_param => sub { $_[0]->param($_[2]) },

166 get_params => sub { $_[1]->get_params() },

167 get_cookie => sub { $_[0]->cookie($_[1]->{S}{cookie_name}) },

168 get_method => sub { $_[0]->request_method() },

169 get_url => sub { $_[0]->url(); },

170 is_login => sub { defined $_[1]->_rp('password_param_name') },

171 login_ok => \&login_ok_password,

172 username_password_ok => sub { die },

173 is_logout => sub { $_[1]->has_a_param('logout_param_names') },

174 is_loggedout => sub { $_[1]->has_a_param('loggedout_param_names') },

175 is_page => sub { return 1 },

176 handle_divert => sub { return 0 },

177 do_redirect => \&do_redirect_cgi, # this hook is allowed to throw

178 cookie_path => "/",

179 get_cookie_domain => \&get_cookie_domain,

180 encrypted_only => 1,

181 gen_start_html => sub { $_[0]->start_html($_[2]); },

182 gen_end_html => sub { $_[0]->end_html(); },

183 gen_login_form => \&gen_plain_login_form,

184 gen_login_link => \&gen_plain_login_link,

185 gettext => sub { gettext($_[2]); },

186 print => sub { print $_[2] or die $!; },

187 },

188 Dbh => undef,

189 };

190 my ($k,$v);

191 while (($k,$v,@_) = @_) {

192 die "unknown setting $k" unless exists $verifier->{S}{$k};

193 $verifier->{S}{$k} = $v;

194 }

195 bless $verifier, $class;

196 $verifier->_dbopen();

197 return $verifier;

198 }

199

200 sub _dbopen ($) {

201 my ($v) = @_;

202 my $dbh = $v->{Dbh};

203 return $dbh if $dbh;

204

205 $v->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$v->{S}{assocdb_path}";

206 my $dsn = $v->{S}{assocdb_dsn};

207

208 my $u = umask 077;

209 $dbh = DBI->connect($dsn, $v->{S}{assocdb_user},

210 $v->{S}{assocdb_password}, {

211 AutoCommit => 0,

212 RaiseError => 1,

213 ShowErrorStatement => 1,

214 });

215 die "$dsn $! ?" unless $dbh;

216 $v->{Dbh} = $dbh;

217

218 eval {

219 $v->_db_transaction(sub {

220 local ($dbh->{PrintError}) = 0;

221 $dbh->do("CREATE TABLE $v->{S}{assocdb_table} (".

222 " associd VARCHAR PRIMARY KEY,".

223 " username VARCHAR,".

224 " last INTEGER NOT NULL".

225 ")");

226 });

227 };

228 return $dbh;

229 }

230

231 sub disconnect ($) {

232 my ($v) = @_;

233 my $dbh = $v->{Dbh};

234 return unless $dbh;

235 $dbh->disconnect();

236 }

237

238 sub _db_transaction ($$) {

239 my ($v, $fn) = @_;

240 my $retries = 10;

241 my $rv;

242 my $dbh = $v->{Dbh};

243 print STDERR "DT entry\n";

244 for (;;) {

245 print STDERR "DT loop\n";

246 if (!eval {

247 $rv = $fn->();

248 print STDERR "DT fn ok\n";

249 1;

250 }) {

251 print STDERR "DT fn error\n";

252 { local ($@); $dbh->rollback(); }

253 print STDERR "DT fn throwing\n";

254 die $@;

255 }

256 print STDERR "DT fn eval ok\n";

257 if (eval {

258 $dbh->commit();

259 print STDERR "DT commit ok\n";

260 1;

261 }) {

262 print STDERR "DT commit eval ok $rv\n";

263 return $rv;

264 }

265 print STDERR "DT commit throw?\n";

266 die $@ if !--$retries;

267 print STDERR "DT loop again\n";

268 }

269 }

270

271 #---------- request object methods ----------

272

273 sub new_request {

274 my ($classbase, $cgi, @extra) = @_;

275 if (!ref $classbase) {

276 $classbase = $classbase->new_verifier(@extra);

277 } else {

278 die if @extra;

279 }

280 my $r = {

281 V => $classbase,

282 S => $classbase->{S},

283 Dbh => $classbase->{Dbh},

284 Cgi => $cgi,

285 };

286 bless $r, ref $classbase;

287 }

288

289 sub _ch ($$@) { # calls an application hook

290 my ($r,$methname, @args) = @_;

291 my $methfunc = $r->{S}{$methname};

292 die "$methname ?" unless $methfunc;

293 return $methfunc->($r->{Cgi}, $r, @args);

294 }

295

296 sub _rp ($$@) {

297 my ($r,$pnvb) = @_;

298 my $pn = $r->{S}{$pnvb};

299 my $p = scalar $r->_ch('get_param',$pn)

300 }

301

302 sub _gt ($$) { my ($r, $t) = @_; return $r->_ch('gettext',$t); }

303 sub _print ($$) { my ($r, @t) = @_; return $r->_ch('print', join '', @t); }

304

305 sub construct_cookie ($$$) {

306 my ($r, $cookv) = @_;

307 return undef unless $cookv;

308 my $c = $r->{Cgi};

309 my @ca = (-name => $r->{S}{cookie_name},

310 -value => $cookv,

311 -path => $r->{S}{cookie_path},

312 -domain => $r->_ch('get_cookie_domain'),

313 -expires => '+'.$r->{S}{login_timeout}.'s',

314 -secure => $r->{S}{encrypted_only});

315 my $cookie = $c->cookie(@ca);

316 print STDERR "CC $r $c $cookv $cookie (@ca).\n";

317 return $cookie;

318 }

319

320 # pages/param-sets are

321 # n normal non-mutating page

322 # r retrieval of information for JS, non-mutating

323 # m mutating page

324 # u update of information by JS, mutating

325 # i login

326 # o logout

327 # O "you have just logged out" page load

328

329 # in cook and par,

330 # a, aN anything including -

331 # t, tN temporary value (in our db, no logged in user yet)

332 # y, yN value corresponds to logged-in user

333 # n, nN value not in our db

334 # x, xN t or y

335 # - no value supplied (represented in code as $cookt='')

336 # if N differs the case applies only when the two values differ

337 # (eg, a1 y2 does not apply when the logged-in value is supplied twice)

338

339 # "stale session" means request originates from a page from a login

340 # session which has been revoked (eg by logout); "cleared session"

341 # means request originates from a browser which has a different (or

342 # no) cookie.

343

344 # Case analysis, cookie mode, app promises re mutate:

345 # cook parm meth form

346 #

347 # any - POST nrmuoi bug or attack, fail

348 # any - GET rmuoi bug or attack, fail

349 # any any GET muoi bug or attack, fail

350 # any t any nrmu bug or attack, fail

351 #

352 # - - GET O "just logged out" page

353 # (any other) O bug or attack, fail

354 #

355 # a1 a2 POST o logout

356 # if a1 is valid, revoke it

357 # if a2 is valid, revoke it

358 # delete cookie

359 # redirect to "just logged out" page

360 # (which contains link to login form)

361 #

362 # - t POST i complain about cookies being disabled

363 # (with link to login form)

364 #

365 # any n POST i complain about stale login form

366 # show new login form

367 #

368 # x1 t2 POST i login (or switch user)

369 # if bad

370 # show new login form

371 # if good

372 # revoke x1 if it was valid and !=t2

373 # upgrade t2 to y2 in our db (setting username)

374 # set cookie to t2

375 # redirect to GET of remaining params

376 #

377 # t1 a2 ANY nrmu treat as - a2 ANY

378 #

379 # y - GET n cross-site link

380 # show data

381 #

382 # y y GET nr fine, show page or send data

383 # y y POST nrmu mutation is OK, do operation

384 #

385 # y1 y2 GET nr request from stale page

386 # do not revoke y2 as not RESTful

387 # treat as y1 n GET

388 #

389 # y1 y2 POST nrmu request from stale page

390 # revoke y2

391 # treat as y1 n POST

392 #

393 # y n GET n intra-site link from stale page,

394 # treat as cross-site link, show data

395 #

396 # y n POST n m intra-site form submission from stale page

397 # show "session interrupted"

398 # with link to main data page

399 #

400 # y n GET r intra-site request from stale page

401 # fail

402 #

403 # y n POST r u intra-site request from stale page

404 # fail

405 #

406 # -/n y2 GET nr intra-site link from cleared session

407 # do not revoke y2 as not RESTful

408 # treat as -/n n GET

409 #

410 # -/n y2 POST nrmu request from cleared session

411 # revoke y2

412 # treat as -/n n POST

413 #

414 # -/n -/n GET n cross-site link but user not logged in

415 # show login form with redirect to orig params

416 # generate fresh cookie

417 #

418 # -/n n GET rmu user not logged in

419 # fail

420 #

421 # -/n n POST n m user not logged in

422 # show login form

423 #

424 # -/n n POST r u user not logged in

425 # fail

426

427 sub _check_divert_core ($) {

428 my ($r) = @_;

429

430 my $meth = $r->_ch('get_method');

431 my $cookv = $r->_ch('get_cookie');

432 my $parmv = $r->_rp('assoc_param_name');

433

434 my ($cookt,$cooku) = $r->_db_lookup($cookv);

435 my $parmt = $r->_db_lookup($parmv);

436

437 print STDERR "_c_d_c cookt=$cookt parmt=$parmt\n";

438

439 if ($r->_ch('is_logout')) {

440 $r->_must_be_post();

441 die unless $parmt;

442 $r->_db_revoke($cookv);

443 $r->_db_revoke($parmv);

444 return ({ Kind => 'REDIRECT-LOGGEDOUT',

445 Message => "Logging out...",

446 CookieVal => '',

447 Params => { } });

448 }

449 if ($r->_ch('is_loggedout')) {

450 die unless $meth eq 'GET';

451 die unless $cookt;

452 die unless $parmt;

453 return ({ Kind => 'SMALLPAGE-LOGGEDOUT',

454 Message => "You have been logged out.",

455 CookieVal => '',

456 Params => { } });

457 }

458 if ($r->_ch('is_login')) {

459 $r->_must_be_post();

460 return ({ Kind => 'LOGIN-STALE',

461 Message => "Stale session; you need to log in again.",

462 CookieVal => $r->_fresh_cookie(),

463 Params => { } })

464 if $parmt eq 'n';

465 die unless $parmt eq 't' || $parmt eq 'y';

466 return ({ Kind => 'SMALLPAGE-NOCOOKIE',

467 Message => "You do not seem to have cookies enabled. ".

468 "You must enable cookies as we use them for login.",

469 CookieVal => $r->_fresh_cookie(),

470 Params => $r->_chain_params() })

471 if !$cookt && $parmt eq 't';

472 my $username = $r->_ch('login_ok');

473 return ({ Kind => 'LOGIN-BAD',

474 Message => "Incorrect username/password.",

475 CookieVal => $cookv,

476 Params => $r->_chain_params() })

477 unless defined $username && length $username;

478 $r->_db_revoke($cookv)

479 if defined $cookv && !(defined $parmv && $cookv eq $parmv);

480 $r->_db_record_login_ok($parmv,$username);

481 return ({ Kind => 'REDIRECT-LOGGEDIN',

482 Message => "Logging in...",

483 CookieVal => $parmv,

484 Params => $r->_chain_params() });

485 }

486 if ($cookt eq 't') {

487 $cookt = '';

488 }

489 die if $parmt eq 't';

490

491 if ($cookt eq 'y' && $parmt eq 'y' && $cookv ne $parmv) {

492 $r->_db_revoke($parmv) if $meth eq 'POST';

493 $parmt = 'n';

494 }

495

496 if ($cookt ne 'y') {

497 die unless !$cookt || $cookt eq 'n';

498 die unless !$parmt || $parmt eq 'n' || $parmt eq 'y';

499 my $newv = $r->_fresh_cookie();

500 if ($meth eq 'GET') {

501 return ({ Kind => 'LOGIN-INCOMINGLINK',

502 Message => "You need to log in again.",

503 CookieVal => $newv,

504 Params => $r->_chain_params() });

505 } else {

506 $r->_db_revoke($parmv);

507 return ({ Kind => 'LOGIN-FRESH',

508 Message => "You need to log in again.",

509 CookieVal => $newv,

510 Params => { } });

511 }

512 }

513

514 if (!$r->{S}{promise_check_mutate}) {

515 if ($meth ne 'POST') {

516 return ({ Kind => 'MAINPAGEONLY',

517 Message => 'Entering via cross-site link.',

518 CookieVal => $cookv,

519 Params => { } });

520 # NB caller must then ignore params & path!

521 # if this is too hard they can spit out a small form

522 # with a "click to continue"

523 }

524 }

525

526 die unless $cookt eq 'y';

527 die unless $parmt eq 'y';

528 die unless $cookv eq $parmv;

529 $r->{Assoc} = $cookv;

530 $r->{UserOK} = $cooku;

531 print STDERR "C-D-C OK\n";

532 return undef;

533 }

534

535 sub _chain_params ($) {

536 my ($r) = @_;

537 my %p = %{ $r->_ch('get_params') };

538 foreach my $pncn (keys %{ $r->{S} }) {

539 my $names;

540 if ($pncn =~ m/_param_name$/) {

541 my $name = $r->{S}{$pncn};

542 die "$pncn ?" if ref $name;

543 $names = [ $name ];

544 } elsif ($pncn =~ m/_param_names$/) {

545 $names = $r->{S}{$pncn};

546 } else {

547 next;

548 }

549 foreach my $name (@$names) {

550 delete $p{$name};

551 }

552 }

553 return \%p;

554 }

555

556 sub _db_lookup ($$) {

557 my ($r,$v) = @_;

558 # returns ($t,$username)

559 # where $t is one of "t" "y" "n", or "" (for -)

560

561 my $dbh = $r->{Dbh};

562

563 my $row = $dbh->selectrow_arrayref("SELECT username, last".

564 " FROM $r->{S}{assocdb_table}".

565 " WHERE associd = ?", {}, $v);

566 return ('') unless defined $row;

567

568 my ($nusername, $nlast) = @$row;

569

570 my $timeout = $r->{S}{login_timeout};

571 return ('n') unless !defined $timeout || time <= $nlast + $timeout;

572

573 return ('t') unless defined $nusername;

574

575 # hooray

576 return ('y', $nusername);

577 }

578

579 sub _db_revoke ($$) {

580 # revokes $v if it's valid; no-op if it's not

581 my ($r,$v) = @_;

582

583 my $dbh = $r->{Dbh};

584

585 $dbh->do("DELETE FROM $r->{S}{assocdb_table}".

586 " WHERE associd = ?", {}, $v);

587 }

588

589 sub _db_record_login_ok ($$$) {

590 my ($r,$v,$user) = @_;

591 $r->_db_revoke($v);

592 my $dbh = $r->{Dbh};

593 $dbh->do("INSERT INTO $r->{S}{assocdb_table}".

594 " (associd, username, last) VALUES (?,?,?)", {},

595 $v, $user, time);

596 }

597

598 sub check_divert ($) {

599 my ($r) = @_;

600 if (exists $r->{Divert}) {

601 return $r->{Divert};

602 }

603 my $dbh = $r->{Dbh};

604 $r->{Divert} = $r->_db_transaction(sub { $r->_check_divert_core(); });

605 $dbh->commit();

606 print STDERR Dumper($r->{Divert});

607 return $r->{Divert};

608 }

609

610 sub get_divert ($) {

611 my ($r) = @_;

612 die "unchecked" unless exists $r->{Divert};

613 return $r->{Divert};

614 }

615

616 sub get_username ($) {

617 my ($r) = @_;

618 my $divert = $r->get_divert();

619 return undef if $divert;

620 return $r->{UserOK};

621 }

622

623 sub url_with_query_params ($$) {

624 my ($r, $params) = @_;

625 my $uri = URI->new($r->_ch('get_url'));

626 $uri->query_form(flatten_params($params));

627 return $uri->as_string();

628 }

629

630 sub _cgi_header_args ($$@) {

631 my ($r, $cookie, @ha) = @_;

632 unshift @ha, qw(-type text/html);

633 push @ha, (-cookie => $cookie) if defined $cookie;

634 print STDERR "_cgi_header_args ",join('|',@ha),".\n";

635 return @ha;

636 }

637

638 sub check_ok ($) {

639 my ($r) = @_;

640

641 my ($divert) = $r->check_divert();

642 return 1 if !$divert;

643

644 my $handled = $r->_ch('handle_divert',$divert);

645 return 0 if $handled;

646

647 my $kind = $divert->{Kind};

648 my $cookieval = $divert->{CookieVal};

649 my $params = $divert->{Params};

650 my $cookie = $r->construct_cookie($cookieval);

651

652 if ($kind =~ m/^REDIRECT-/) {

653 # for redirects, we honour stored NextParams and SetCookie,

654 # as we would for non-divert

655 if ($kind eq 'REDIRECT-LOGGEDOUT') {

656 $params->{$r->{S}{loggedout_param_names}[0]} = 1;

657 } elsif ($kind eq 'REDIRECT-LOGOUT') {

658 $params->{$r->{S}{logout_param_names}[0]} = 1;

659 } elsif ($kind eq 'REDIRECT-LOGGEDIN') {

660 } else {

661 die;

662 }

663 my $new_url = $r->url_with_query_params($params);

664 $r->_ch('do_redirect',$new_url, $cookie);

665 return 0;

666 }

667

668 my ($title, @body);

669 if ($kind =~ m/^LOGIN-/) {

670 $title = $r->_gt('Login');

671 push @body, $r->_gt($divert->{Message});

672 push @body, $r->_ch('gen_login_form', $params);

673 } elsif ($kind =~ m/^SMALLPAGE-/) {

674 $title = $r->_gt('Not logged in');

675 push @body, $r->_gt($divert->{Message});

676 push @body, $r->_ch('gen_login_link');

677 } else {

678 die $kind;

679 }

680

681 $r->_print($r->{Cgi}->header($r->_cgi_header_args($cookie)),

682 $r->_ch('gen_start_html',$title),

683 (join "\n", @body),

684 $r->_ch('gen_end_html'));

685 return 0;

686 }

687

688 sub _random ($$) {

689 my ($r, $bytes) = @_;

690 my $v = $r->{V};

691 my $rsf = $v->{RandomHandle};

692 my $rsp = $r->{S}{random_source};

693 if (!$rsf) {

694 $v->{RandomHandle} = $rsf = new IO::File $rsp, '<' or die "$rsp $!";

695 }

696 my $bin;

697 $!=0;

698 read($rsf,$bin,$bytes) == $bytes or die "$rsp $!";

699 close $rsf;

700 my $out = unpack "H*", $bin;

701 print STDERR "_random out $out\n";

702 return $out;

703 }

704

705 sub _fresh_cookie ($) {

706 my ($r) = @_;

707 print STDERR "_fresh_cookie\n";

708 my $bytes = ($r->{S}{associdlen} + 7) >> 3;

709 return $r->_random($bytes);

710 }

711

712 sub _assert_checked ($) {

713 my ($r) = @_;

714 die "unchecked" unless exists $r->{Divert};

715 }

716

717 sub check_mutate ($) {

718 my ($r) = @_;

719 $r->_assert_checked();

720 die if $r->{Divert};

721 my $meth = $r->_ch('get_method');

722 die "mutating non-POST" if $meth ne 'POST';

723 }

724

725 #---------- output ----------

726

727 sub secret_val ($) {

728 my ($r) = @_;

729 $r->_assert_checked();

730 return defined $r->{Assoc} ? $r->{Assoc} : '';

731 }

732

733 sub secret_hidden_html ($) {

734 my ($r) = @_;

735 return $r->{Cgi}->hidden(-name => $r->{S}{assoc_param_name},

736 -default => $r->secret_val());

737 }

738

739 sub secret_cookie ($) {

740 my ($r) = @_;

741 #print STDERR "SC\n";

742 my $cookv = $r->construct_cookie($r->secret_val());

743 #print STDERR "SC=$cookv\n";

744 return $cookv;

745 }

746

747 __END__

748

749 =head1 NAME

750

751 CGI::Auth::Hybrid - web authentication optionally using cookies

752

753 =head1 SYNOPSYS

754

755 my $verifier = CGI::Auth::Hybrid->new_verifier(setting => value,...);

756 my $authreq = $verifier->new_request($cgi_request_object);

757

758 my $authreq = CGI::Auth::Hybrid->new_request($cgi_request_object,

759 setting => value,...);

760

761 =head1 USAGE PATTERN FOR SIMPLE APPLICATIONS

762

763 $authreq->check_ok() or return;

764

765 blah blah blah

766 $authreq->check_mutate();

767 blah blah blah

768

769 =head1 USAGE PATTERN FOR FANCY APPLICATIONS

770

771 my $divert_kind = $authreq->check_divert();

772 if ($divert_kind) {

773 if ($divert_kind eq 'LOGGEDOUT') {

774 print "goodbye you are now logged out" and quit

775 } elsif ($divert_kind eq 'NOCOOKIES') {

776 print "you need cookies" and quit

777 ... etc.

778 }

779 }

780

781 blah blah blah

782 $authreq->check_mutate();

783 blah blah blah