cgi-auth-hybrid.pm

   1 # -*- perl -*-
   2
   3 # This is part of CGI::Auth::Hybrid, a perl CGI authentication module.
   4 # Copyright (C) 2012 Ian Jackson.
   5 #
   6 # This program is free software: you can redistribute it and/or modify
   7 # it under the terms of the GNU Affero General Public License as published by
   8 # the Free Software Foundation, either version 3 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU Affero General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU Affero General Public License
  17 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 BEGIN {
  20     use Exporter   ();
  21     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  22
  23     $VERSION     = 1.00;
  24     @ISA         = qw(Exporter);
  25     @EXPORT      = qw();
  26     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  27
  28     @EXPORT_OK   = qw(setup);
  29 }
  30 our @EXPORT_OK;
  31
  32 use DBI;
  33 use CGI;
  34
  35 #---------- verifier object methods ----------
  36
  37 sub new_verifier {
  38     my $class = shift;
  39     my $s = {
  40         S => {
  41             assocdb_path => 'cah-assocs.db';
  42             assocdb_dsn => undef,
  43             assocdb_user => '',
  44             assocdb_password => '',
  45             assocdb_table => 'assocs',
  46             random_source => '/dev/urandom',
  47             associdlen => 128, # bits
  48             login_timeout => 86400, # seconds
  49             param_name => 'cah_associd',
  50             cookie_name => 'cah_associd', # make undef to disable cookie
  51             get_param => sub { $_[0]->param($s->{S}{param_name}) },
  52             get_cookie => sub { $s->{S}{cookie_name}
  53                                 ? $_[0]->cookie($s->{S}{cookie_name})
  54                                 : '' },
  55             get_method => sub { $_[0]->request_method() },
  56         },
  57         Dbh => undef,
  58     };
  59     my ($k,$v);
  60     while (($k,$v,@_) = @_) {
  61         die "unknown setting $k" unless exists $s->{S}{$k};
  62         $s->{S}{$k} = $v;
  63     }
  64     bless $s, $class;
  65     $s->_dbopen();
  66     return $s;
  67 }
  68
  69 sub _dbopen ($) {
  70     my ($s) = @_;
  71     my $dbh = $s->{Dbh};
  72     return $dbh if $dbh;
  73
  74     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
  75
  76     my $u = umask 077;
  77     $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
  78                      $s->{S}{assocdb_password}, {
  79                          AutoCommit => 0, RaiseError => 1,
  80                      });
  81     die "${assocdb_dsn} $! ?" unless $dbh;
  82     $s->{Dbh} = $dbh;
  83
  84     $dbh->do("BEGIN");
  85
  86     eval {
  87         $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
  88                  " associd VARCHAR PRIMARY KEY,".
  89                  " username VARCHAR,".
  90                  " last INTEGER"
  91                  ")");
  92     };
  93     return $dbh;
  94 }
  95
  96 #---------- request object methods ----------
  97
  98 sub new_request {
  99     my ($classbase, $cgi, @extra) = @_;
 100     if (!ref $classbase) {
 101         $classbase = $classbase->new_verifier(@extra);
 102     } else {
 103         die if @extra;
 104     }
 105     my $r = {
 106         S => $classbase->{S},
 107         Dbh => $classbase->{Dbh},
 108         Cgi => $cgi,
 109     };
 110     bless $r, ref $classbase;
 111 }
 112
 113 sub _cm ($$@) {
 114     my ($r,$methname, @args) = @_;
 115     my $methfunc = $r->{S}{$methname};
 116     return $methfunc->($r->{Cgi}, $r, @args);
 117 }
 118
 119 sub record_login ($$) {
 120     my ($r,$nusername) = @_;
 121     my $rsp = $r->{S}{random_source};
 122     my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
 123     my $bytes = ($r->{S}{associdlen} + 7) >> 3;
 124     my $nassocbin;
 125     $!=0;
 126     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
 127     close $rsf;
 128     my $nassoc = unpack "H*", $nassocbin;
 129     my $dbh = $r->{Dbh};
 130     $dbh->do("INSERT INTO $r->{S}{assocdb_table}".
 131              " (associd, username, last) VALUES (?,?,?)", {},
 132              $nassoc, $nusername, time);
 133     $dbh->do("COMMIT");
 134     $r->{U} = $nusername;
 135     $r->{A} = $nassoc;
 136 }
 137
 138 sub _check ($) {
 139     my ($r) = @_;
 140     my $qassoc = $r->_cm('get_param');
 141     if (!defined $qassoc) {
 142         $qassoc = $r->_cm('get_cookie');
 143         return undef unless defined $qassoc;
 144         return undef unless $r->_cm('get_method') eq 'GET';
 145     }
 146     my $dbh = $r->_dbopen();
 147     my ($nusername, $nlast) =
 148         $dbh->selectrow_array("SELECT username, last".
 149                               " FROM $r->{S}{assocdb_table}".
 150                               " WHERE associd = ?", {}, $qassoc);
 151     return undef unless defined $nusername;
 152     my $timeout = $r->{S}{login_timeout};
 153     return undef unless !defined $timeout || time <= $nlast + $timeout;
 154
 155     return ($nusername, $qassoc);
 156 }
 157
 158 sub check ($) {
 159     my ($r) = @_;
 160
 161     my ($nusername, $qassoc) = $r->_check() or return undef;
 162
 163     # hooray
 164     $dbh->do("UPDATE $r->{S}{assocdb_table}".
 165              " SET last = ?".
 166              " WHERE associd = ?", {}, time, $qassoc);
 167     $dbh->do("COMMIT");
 168
 169     $r->{U} = $nusername;
 170     $r->{A} = $qassoc;
 171     return $username;
 172 }
 173
 174 sub logout ($) {
 175     my ($r) = @_;
 176
 177     if (my ($nusername, $qassoc) = $r->_check()) {
 178         $dbh->do("DELETE FROM $r->{S}{assocdb_table}".
 179                  " WHERE associd = ?", {}, $qassoc);
 180         $dbh->do("COMMIT");
 181     }
 182 }
 183
 184 sub username ($) {
 185     my ($r) = @_;
 186     return $r->{U};
 187
 188 sub hiddenv ($) {
 189     my ($r) = @_;
 190     return defined $r->{A} ? $r->{A} : '';
 191 }
 192
 193 sub hiddena ($) {
 194     my ($r) = @_;
 195     return (-name => $r->{param_name},
 196             -default => $r->hiddenv());
 197 }
 198
 199 sub hiddenh ($) {
 200     my ($r) = @_;
 201     return hidden($r->hiddena());
 202 }
 203
 204 sub cookieac ($) {
 205     my ($r) = @_;
 206     return (-name => $r->{cookie_name},
 207             -value => hiddenv());
 208