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     );
  25
  26 use DBI;
  27
  28 our $dbh;
  29
  30 sub setup {
  31     my ($k,$v);
  32     while (($k,$v,@_) = @_) {
  33         die "unknown setting $k" unless %_s{$k};
  34         $_s{$k} = $v;
  35     }
  36 }
  37
  38 sub _dbopen () {
  39     return if $dbh;
  40
  41     $_s{assocdb_dsn}="dbi:SQLite:dbname=$s_{assocdb_path}"
  42         if !$_s{assocdb_dsn};
  43
  44     my $u = umask 077;
  45     $dbh = DBI->open($_s{assocdb_dsn}, $s_{assocdb_user},
  46                      $s_{assocdb_password}, {
  47                          AutoCommit => 0, RaiseError => 1,
  48                      });
  49     die "${assocdb_dsn} $! ?" unless $dbh;
  50
  51     $dbh->do("BEGIN");
  52
  53     eval {
  54         $dbh->do("CREATE TABLE $_s{assocdb_table} (".
  55                  " associd VARCHAR PRIMARY KEY,".
  56                  " username VARCHAR".
  57                  ")");
  58     };
  59 }
  60
  61 sub record_login ($) {
  62     my ($nusername) = @_;
  63     my $rs = new IO::File $_s{random_source}, '<'
  64         or die "$_s{random_source} $!";
  65     my $bytes = ($_s{associdlen} + 7) >> 3;
  66     my $nassocbin;
  67     $!=0;
  68     read($rs,$nassocbin,$bytes) == $bytes or die "$s_{random_source} $!";
  69     my $nassoc = unpack "H*", $nassocbin;
  70     _dbopen();
  71     $dbh->do("INSERT INTO $_s{assocdb_table}".
  72              " (associd, username) VALUES (?,?)", {},
  73              $nassoc, $nusername);
  74     $dbh->do("COMMIT");
  75     $username = $nusername;
  76     $assoc =    $nassoc;
  77 }