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 our %_s = (
  17     assocdb_path => 'cah-assocs.db';
  18     assocdb_dsn => undef,
  19     assocdb_user => '',
  20     assocdb_password => '',
  21     assocdb_table => 'assocs',
  22     random_source => '/dev/urandom',
  23     associdlen => 128, # bits
  24     param_name => 'cah_associd',
  25     cookie_name => 'cah_associd', # make undef to disable cookie
  26     param_get => sub { _c()->param($s_{param_name}) },
  27     cookie_get => sub { $_s{cookie_name} ? _c()->param($s_{cookie_name}) : '' },
  28     );
  29
  30 use DBI;
  31
  32 our $dbh;
  33
  34 sub new {
  35     my ($k,$v);
  36     while (($k,$v,@_) = @_) {
  37         die "unknown setting $k" unless %_s{$k};
  38         $_s{$k} = $v;
  39     }
  40 }
  41
  42 sub _dbopen () {
  43     return if $dbh;
  44
  45     $_s{assocdb_dsn}="dbi:SQLite:dbname=$s_{assocdb_path}"
  46         if !$_s{assocdb_dsn};
  47
  48     my $u = umask 077;
  49     $dbh = DBI->open($_s{assocdb_dsn}, $s_{assocdb_user},
  50                      $s_{assocdb_password}, {
  51                          AutoCommit => 0, RaiseError => 1,
  52                      });
  53     die "${assocdb_dsn} $! ?" unless $dbh;
  54
  55     $dbh->do("BEGIN");
  56
  57     eval {
  58         $dbh->do("CREATE TABLE $_s{assocdb_table} (".
  59                  " associd VARCHAR PRIMARY KEY,".
  60                  " username VARCHAR".
  61                  ")");
  62     };
  63 }
  64
  65 sub record_login ($) {
  66     my ($nusername) = @_;
  67     my $rs = new IO::File $_s{random_source}, '<'
  68         or die "$_s{random_source} $!";
  69     my $bytes = ($_s{associdlen} + 7) >> 3;
  70     my $nassocbin;
  71     $!=0;
  72     read($rs,$nassocbin,$bytes) == $bytes or die "$s_{random_source} $!";
  73     my $nassoc = unpack "H*", $nassocbin;
  74     _dbopen();
  75     $dbh->do("INSERT INTO $_s{assocdb_table}".
  76              " (associd, username) VALUES (?,?)", {},
  77              $nassoc, $nusername);
  78     $dbh->do("COMMIT");
  79     $username = $nusername;
  80     $assoc =    $nassoc;
  81 }
  82
  83 sub check () {
  84     my $passocid = $_s{param_get}();
  85     my $cassocid = $_s{cookie_get}();
  86     if (