chiark / gitweb /
wip before timeout
[cgi-auth-flexible.git] / 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