cgi-auth-hybrid.pm

   1 # -*- perl -*-
   2
   3 BEGIN {
   4     use Exporter   ();
   5     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
   6
   7     $VERSION     = 1.00;
   8     @ISA         = qw(Exporter);
   9     @EXPORT      = qw();
  10     %EXPORT_TAGS = ( );     # eg: TAG => [ qw!name1 name2! ],
  11
  12     @EXPORT_OK   = qw(setup);
  13 }
  14 our @EXPORT_OK;
  15
  16 use DBI;
  17
  18 sub new {
  19     my $class = shift;
  20     my $s = {
  21         S => {
  22             assocdb_path => 'cah-assocs.db';
  23             assocdb_dsn => undef,
  24             assocdb_user => '',
  25             assocdb_password => '',
  26             assocdb_table => 'assocs',
  27             random_source => '/dev/urandom',
  28             associdlen => 128, # bits
  29             login_timeout => 86400, # seconds
  30             param_name => 'cah_associd',
  31             cookie_name => 'cah_associd', # make undef to disable cookie
  32             cgi => undef,
  33             get_param => sub { $s->_c()->param($s->{S}{param_name}) },
  34             get_cookie => sub { $s->{S}{cookie_name}
  35                                 ? $s->_c()->cookie($s->{S}{cookie_name})
  36                                 : '' },
  37             get_method => sub { $s->_c()->request_method() },
  38         },
  39         D => undef,
  40     };
  41     my ($k,$v);
  42     while (($k,$v,@_) = @_) {
  43         die "unknown setting $k" unless exists $s->{S}{$k};
  44         $s->{S}{$k} = $v;
  45     }
  46     bless $s, $class;
  47     return $s;
  48 }
  49
  50 sub _c ($) {
  51     my ($s) = @_;
  52     return $s->{S}{cgi};
  53 }
  54
  55 sub _dbopen ($) {
  56     my ($s) = @_;
  57     my $dbh = $s->{D};
  58     return $dbh if $dbh;
  59
  60     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
  61
  62     my $u = umask 077;
  63     $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
  64                      $s->{S}{assocdb_password}, {
  65                          AutoCommit => 0, RaiseError => 1,
  66                      });
  67     die "${assocdb_dsn} $! ?" unless $dbh;
  68     $s->{D} = $dbh;
  69
  70     $dbh->do("BEGIN");
  71
  72     eval {
  73         $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
  74                  " associd VARCHAR PRIMARY KEY,".
  75                  " username VARCHAR,".
  76                  " last INTEGER"
  77                  ")");
  78     };
  79     return $dbh;
  80 }
  81
  82 sub record_login ($$) {
  83     my ($s,$nusername) = @_;
  84     my $rsp = $s->{S}{random_source};
  85     my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
  86     my $bytes = ($s->{S}{associdlen} + 7) >> 3;
  87     my $nassocbin;
  88     $!=0;
  89     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
  90     close $rsf;
  91     my $nassoc = unpack "H*", $nassocbin;
  92     my $dbh = $s->_dbopen();
  93     $dbh->do("INSERT INTO $s->{S}{assocdb_table}".
  94              " (associd, username, last) VALUES (?,?,?)", {},
  95              $nassoc, $nusername, time);
  96     $dbh->do("COMMIT");
  97     $username = $nusername;
  98     $assoc =    $nassoc;
  99 }
 100
 101 sub _check ($) {
 102     my ($s) = @_;
 103     my $qassoc = $s->{S}{param_get}();
 104     if (!defined $qassoc) {
 105         $qassoc = $s->{S}{cookie_get}();
 106         return undef unless defined $qassoc;
 107         return undef unless $s->{S}{get_method}() eq 'GET';
 108     }
 109     my $dbh = $s->_dbopen();
 110     my ($nusername, $nlast) =
 111         $dbh->selectrow_array("SELECT username, last".
 112                               " FROM $s->{S}{assocdb_table}".
 113                               " WHERE associd = ?", {}, $qassoc);
 114     return undef unless defined $nusername;
 115     my $timeout = $s->{S}{login_timeout};
 116     return undef unless !defined $timeout || time <= $nlast + $timeout;
 117
 118     return ($nusername, $qassoc);
 119 }
 120
 121 sub check ($) {
 122     my ($s) = @_;
 123
 124     my ($nusername, $qassoc) = $s->_check() or return undef;
 125
 126     # hooray
 127     $dbh->do("UPDATE $s->{S}{assocdb_table}".
 128              " SET last = ?".
 129              " WHERE associd = ?", {}, time, $qassoc);
 130     $dbh->do("COMMIT");
 131
 132     $username = $nusername;
 133     $assoc =    $qassoc;
 134     return $username;
 135 }
 136
 137 sub logout ($) {
 138     my ($s) = @_;
 139
 140     if (my ($nusername, $qassoc) = $s->_check()) {
 141         $dbh->do("DELETE FROM $s->{S}{assocdb_table}".
 142                  " WHERE associd = ?", {}, $qassoc);
 143         $dbh->do("COMMIT");
 144     }
 145 }