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