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 sub new {
  36     my $class = shift;
  37     my $s = {
  38         S => {
  39             assocdb_path => 'cah-assocs.db';
  40             assocdb_dsn => undef,
  41             assocdb_user => '',
  42             assocdb_password => '',
  43             assocdb_table => 'assocs',
  44             random_source => '/dev/urandom',
  45             associdlen => 128, # bits
  46             login_timeout => 86400, # seconds
  47             param_name => 'cah_associd',
  48             cookie_name => 'cah_associd', # make undef to disable cookie
  49             cgi => undef,
  50             get_param => sub { $s->_c()->param($s->{S}{param_name}) },
  51             get_cookie => sub { $s->{S}{cookie_name}
  52                                 ? $s->_c()->cookie($s->{S}{cookie_name})
  53                                 : '' },
  54             get_method => sub { $s->_c()->request_method() },
  55         },
  56         D => undef,
  57     };
  58     my ($k,$v);
  59     while (($k,$v,@_) = @_) {
  60         die "unknown setting $k" unless exists $s->{S}{$k};
  61         $s->{S}{$k} = $v;
  62     }
  63     bless $s, $class;
  64     return $s;
  65 }
  66
  67 sub _c ($) {
  68     my ($s) = @_;
  69     return $s->{S}{cgi};
  70 }
  71
  72 sub _dbopen ($) {
  73     my ($s) = @_;
  74     my $dbh = $s->{D};
  75     return $dbh if $dbh;
  76
  77     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
  78
  79     my $u = umask 077;
  80     $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
  81                      $s->{S}{assocdb_password}, {
  82                          AutoCommit => 0, RaiseError => 1,
  83                      });
  84     die "${assocdb_dsn} $! ?" unless $dbh;
  85     $s->{D} = $dbh;
  86
  87     $dbh->do("BEGIN");
  88
  89     eval {
  90         $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
  91                  " associd VARCHAR PRIMARY KEY,".
  92                  " username VARCHAR,".
  93                  " last INTEGER"
  94                  ")");
  95     };
  96     return $dbh;
  97 }
  98
  99 sub record_login ($$) {
 100     my ($s,$nusername) = @_;
 101     my $rsp = $s->{S}{random_source};
 102     my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
 103     my $bytes = ($s->{S}{associdlen} + 7) >> 3;
 104     my $nassocbin;
 105     $!=0;
 106     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
 107     close $rsf;
 108     my $nassoc = unpack "H*", $nassocbin;
 109     my $dbh = $s->_dbopen();
 110     $dbh->do("INSERT INTO $s->{S}{assocdb_table}".
 111              " (associd, username, last) VALUES (?,?,?)", {},
 112              $nassoc, $nusername, time);
 113     $dbh->do("COMMIT");
 114     $s->{U} = $nusername;
 115     $s->{A} = $nassoc;
 116 }
 117
 118 sub _check ($) {
 119     my ($s) = @_;
 120     my $qassoc = $s->{S}{param_get}();
 121     if (!defined $qassoc) {
 122         $qassoc = $s->{S}{cookie_get}();
 123         return undef unless defined $qassoc;
 124         return undef unless $s->{S}{get_method}() eq 'GET';
 125     }
 126     my $dbh = $s->_dbopen();
 127     my ($nusername, $nlast) =
 128         $dbh->selectrow_array("SELECT username, last".
 129                               " FROM $s->{S}{assocdb_table}".
 130                               " WHERE associd = ?", {}, $qassoc);
 131     return undef unless defined $nusername;
 132     my $timeout = $s->{S}{login_timeout};
 133     return undef unless !defined $timeout || time <= $nlast + $timeout;
 134
 135     return ($nusername, $qassoc);
 136 }
 137
 138 sub check ($) {
 139     my ($s) = @_;
 140
 141     my ($nusername, $qassoc) = $s->_check() or return undef;
 142
 143     # hooray
 144     $dbh->do("UPDATE $s->{S}{assocdb_table}".
 145              " SET last = ?".
 146              " WHERE associd = ?", {}, time, $qassoc);
 147     $dbh->do("COMMIT");
 148
 149     $s->{U} = $nusername;
 150     $s->{A} = $qassoc;
 151     return $username;
 152 }
 153
 154 sub logout ($) {
 155     my ($s) = @_;
 156
 157     if (my ($nusername, $qassoc) = $s->_check()) {
 158         $dbh->do("DELETE FROM $s->{S}{assocdb_table}".
 159                  " WHERE associd = ?", {}, $qassoc);
 160         $dbh->do("COMMIT");
 161     }
 162 }
 163
 164 sub username ($) {
 165     my ($s) = @_;
 166     return $s->{U};
 167
 168 sub hiddenv ($) {
 169     my ($s) = @_;
 170     return defined $s->{A} ? $s->{A} : '';
 171 }
 172
 173 sub hiddena ($) {
 174     my ($s) = @_;
 175     return (-name => $s->{param_name},
 176             -default => $s->hiddenv());
 177 }
 178
 179 sub hiddenh ($) {
 180     my ($s) = @_;
 181     return hidden($s->hiddena());
 182 }
 183
 184 sub cookieac ($) {
 185     my ($s) = @_;
 186     return (-name => $s->{cookie_name},
 187             -value => hiddenv());
 188