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             param_name => 'cah_associd',
  30             cookie_name => 'cah_associd', # make undef to disable cookie
  31             cgi => undef,
  32             param_get => sub { $s->_c()->param($s->{S}{param_name}) },
  33             cookie_get => sub { $s->_c()->cookie($s->{S}{cookie_name}) : '' },
  34         },
  35         D => undef,
  36     };
  37     my ($k,$v);
  38     while (($k,$v,@_) = @_) {
  39         die "unknown setting $k" unless exists $s->{S}{$k};
  40         $s->{S}{$k} = $v;
  41     }
  42     bless $s, $class;
  43     return $s;
  44 }
  45
  46 sub _c ($) {
  47     my ($s) = @_;
  48     return $s->{S}{cgi};
  49 }
  50
  51 sub _dbopen ($) {
  52     my ($s) = @_;
  53     my $dbh = $s->{D};
  54     return $dbh if $dbh;
  55
  56     $s->{S}{assocdb_dsn} ||= "dbi:SQLite:dbname=$s->{S}{assocdb_path}";
  57
  58     my $u = umask 077;
  59     $dbh = DBI->open($s->{S}{assocdb_dsn}, $s->{S}{assocdb_user},
  60                      $s->{S}{assocdb_password}, {
  61                          AutoCommit => 0, RaiseError => 1,
  62                      });
  63     die "${assocdb_dsn} $! ?" unless $dbh;
  64     $s->{D} = $dbh;
  65
  66     $dbh->do("BEGIN");
  67
  68     eval {
  69         $dbh->do("CREATE TABLE $s->{S}{assocdb_table} (".
  70                  " associd VARCHAR PRIMARY KEY,".
  71                  " username VARCHAR".
  72                  ")");
  73     };
  74     return $dbh;
  75 }
  76
  77 sub record_login ($$) {
  78     my ($s,$nusername) = @_;
  79     my $rsp = $s->{S}{random_source};
  80     my $rsf = new IO::File $rsp, '<' or die "$rsp $!";
  81     my $bytes = ($s->{S}{associdlen} + 7) >> 3;
  82     my $nassocbin;
  83     $!=0;
  84     read($rsf,$nassocbin,$bytes) == $bytes or die "$rsp $!";
  85     close $rsf;
  86     my $nassoc = unpack "H*", $nassocbin;
  87     my $dbh = $s->_dbopen();
  88     $dbh->do("INSERT INTO $s->{S}{assocdb_table}".
  89              " (associd, username) VALUES (?,?)", {},
  90              $nassoc, $nusername);
  91     $dbh->do("COMMIT");
  92     $username = $nusername;
  93     $assoc =    $nassoc;
  94 }
  95
  96 sub check () {
  97     my $passocid = $s->{S}{param_get}();
  98     my $cassocid = $s->{S}{cookie_get}();
  99     if (