summaryrefslogtreecommitdiff
path: root/lib/VNWeb/Auth.pm
blob: 306bb64cd3b09ac353c6435fa623e5b8aa556cd0 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
# This package provides an 'auth' function and a useful object for dealing with
# VNDB sessions. Usage:
#
#   use VNWeb::Auth;
#
#   if(auth) {
#     ..user is logged in
#   }
#
#   my $success = auth->login($user, $pass);
#   auth->logout;
#
#   my $uid = auth->uid;
#   my $username = auth->username;
#   my $wants_spoilers = auth->pref('spoilers');
#   ..etc
#
#   die "You're not allowed to post!" if !auth->permBoard;
#
package VNWeb::Auth;

use v5.24;
use warnings;
use TUWF;
use Exporter 'import';

use Digest::SHA qw|sha1 sha1_hex|;
use Crypt::URandom 'urandom';
use Crypt::ScryptKDF 'scrypt_raw';
use Encode 'encode_utf8';

use VNDBUtil 'norm_ip';
use VNDB::Config;
use VNWeb::DB;

our @EXPORT = ('auth');

my $auth;
sub auth { $auth }


TUWF::hook before => sub {
    my $cookie = tuwf->reqCookie('auth')||'';
    my($uid, $token_e) = $cookie =~ /^([a-fA-F0-9]{40})\.?(\d+)$/ ? ($2, sha1_hex pack 'H*', $1) : (0, '');

    $auth = __PACKAGE__->new();
    $auth->_load_session($uid, $token_e);
    1;
};


TUWF::hook after => sub { $auth = __PACKAGE__->new() };


# log user IDs (necessary for determining performance issues, user preferences
# have a lot of influence in this)
TUWF::set log_format => sub {
    my(undef, $uri, $msg) = @_;
    sprintf "[%s] %s %s: %s\n", scalar localtime(), $uri, auth ? auth->uid : '-', $msg;
};



use overload bool => sub { defined shift->{uid} };

sub uid      { shift->{uid} }
sub username { shift->{username} }
sub perm     { shift->{perm}||0 }
sub token    { shift->{token} }



# The 'perm' field is a bit field, with the following bits.
# The 'usermod' flag is hardcoded in sql/func.sql for the user_* functions.
# Flag 8 was used for 'staffedit', but is now free for re-use.
# Flag 256 was used for 'affiliates', now also free.
my %perms = qw{
    board        1
    boardmod     2
    edit         4
    tag         16
    dbmod       32
    tagmod      64
    usermod    128
};

sub defaultPerms { $perms{board} + $perms{edit} + $perms{tag} }
sub allPerms     { my $i = 0; $i |= $_ for values %perms; $i }
sub listPerms    { \%perms }


# Create a read-only accessor to check if the current user is authorized to
# perform a particular action.
for my $perm (keys %perms) {
    no strict 'refs';
    *{ "perm".ucfirst($perm) } = sub { (shift->perm() & $perms{$perm}) > 0 }
}


sub _randomascii {
    return join '', map chr($_%92+33), unpack 'C*', urandom shift;
}


# Prepares a plaintext password for database storage
# Arguments: pass, optionally: salt, N, r, p
# Returns: hashed password (hex coded)
sub _preparepass {
    my($self, $pass, $salt, $N, $r, $p) = @_;
    ($N, $r, $p) = @{$self->{scrypt_args}} if !$N;
    $salt ||= urandom(8);
    unpack 'H*', pack 'NCCa8a*', $N, $r, $p, $salt, scrypt_raw(encode_utf8($pass), $self->{scrypt_salt} . $salt, $N, $r, $p, 32);
}


# Hash a password with the same scrypt parameters as the users' current password.
sub _encpass {
    my($self, $uid, $pass) = @_;

    my $args = tuwf->dbVali('SELECT user_getscryptargs(id) FROM users WHERE id =', \$uid);
    return undef if !$args || length($args) != 14;

    my($N, $r, $p, $salt) = unpack 'NCCa8', $args;
    $self->_preparepass($pass, $salt, $N, $r, $p);
}


# Arguments: self, uid, encpass
# Returns: 0 on error, 1 on success
sub _create_session {
    my($self, $uid, $encpass, $pretend) = @_;

    my $token = urandom 20;
    my $token_db = sha1_hex $token;
    return 0 if !tuwf->dbVali('SELECT ',
        sql_func(user_login => \$uid, sql_fromhex($encpass), sql_fromhex $token_db)
    );

    if($pretend) {
        tuwf->dbExeci('SELECT', sql_func user_logout => \$uid, sql_fromhex $token_db);
    } else {
        tuwf->resCookie(auth => unpack('H*', $token).'.'.$uid, httponly => 1, expires => time + 31536000);
        $self->_load_session($uid, $token_db);
    }
    return 1;
}


sub _load_session {
    my($self, $uid, $token_db) = @_;

    my $user = {};
    if($uid) {
        my $loggedin = sql_func(user_isloggedin => 'id', sql_fromhex($token_db));
        $user = tuwf->dbRowi(
            'SELECT id, username, perm, ', sql_totime($loggedin), ' AS lastused',
            'FROM users WHERE id = ', \$uid, 'AND', $loggedin, 'IS NOT NULL'
        );

        # update the sessions.lastused column if lastused < now()-'6 hours'
        tuwf->dbExeci(SELECT => sql_func user_update_lastused => \$user->{id}, sql_fromhex $token_db)
            if $user->{id} && $user->{lastused} < time()-6*3600;
    }

    # Drop the cookie if it's not valid
  	tuwf->resCookie(auth => undef) if !$user->{id} && tuwf->reqCookie('auth');

    $self->{uid}      = $user->{id};
    $self->{username} = $user->{username};
    $self->{perm}     = $user->{perm}||0;
    $self->{token}    = $token_db;
    delete $self->{pref};
}


sub new {
    bless {
        scrypt_salt => config->{scrypt_salt}||die(),
        scrypt_args => config->{scrypt_args}||[ 65536, 8, 1 ],
        csrf_key    => config->{form_salt}||die(),
    }, shift;
}


# Returns 1 on success, 0 on failure
# When $pretend is true, it only tests if the user/pass combination is correct,
# but doesn't actually create a session.
sub login {
    my($self, $user, $pass, $pretend) = @_;
    return 0 if $self->uid || !$user || !$pass;

    my $uid = tuwf->dbVali('SELECT id FROM users WHERE username =', \$user);
    return 0 if !$uid;
    my $encpass = $self->_encpass($uid, $pass);
    return 0 if !$encpass;
    $self->_create_session($uid, $encpass, $pretend);
}


sub logout {
    my $self = shift;
    return if !$self->uid;
    tuwf->dbExeci('SELECT', sql_func user_logout => \$self->uid, sql_fromhex $self->{token});
    $self->_load_session();
}


# Replaces the user's password with a random token that can be used to reset
# the password. Returns ($uid, $token) if the email address is found in the DB,
# () otherwise.
sub resetpass {
    my(undef, $mail) = @_;
    my $token = unpack 'H*', urandom(20);
    my $id = tuwf->dbVali(
        select => sql_func(user_resetpass => \$mail, sql_fromhex sha1_hex lc $token)
    );
    return $id ? ($id, $token) : ();
}


# Checks if the password reset token is valid
sub isvalidtoken {
    my(undef, $uid, $token) = @_;
    tuwf->dbVali(
        select => sql_func(user_isvalidtoken => \$uid, sql_fromhex sha1_hex lc $token)
    );
}


# Change the users' password, drop all existing sessions and create a new session.
# Requires either the current password or a reset token.
# Returns 1 on success, 0 on failure.
sub setpass {
    my($self, $uid, $token, $oldpass, $newpass) = @_;

    my $code = $token
        ? sha1_hex lc $token
        : $self->_encpass($uid, $oldpass);
    return 0 if !$code;

    my $encpass = $self->_preparepass($newpass);
    return 0 if !tuwf->dbVali(
        select => sql_func user_setpass => \$uid, sql_fromhex($code), sql_fromhex($encpass)
    );
    $self->_create_session($uid, $encpass);
}


# Change a users' password, requires that the current logged in user is an admin.
sub admin_setpass {
    my($self, $uid, $pass) = @_;
    my $encpass = $self->_preparepass($pass);
    tuwf->dbVali(select =>
        sql_func user_admin_setpass => \$uid, \$self->{uid}, sql_fromhex($self->{token}), sql_fromhex($encpass)
    )
}


# Generate an CSRF token for this user, also works for anonymous users (albeit
# less secure). The key is only valid for the current hour, tokens for previous
# hours can be generated by passing a negative $hour_offset.
sub csrftoken {
    my($self, $hour_offset) = @_;
    sha1_hex sprintf '%s%s%d',
        $self->{csrf_key} || 'csrf-token',      # Server secret
        $self->{token} || norm_ip(tuwf->reqIP), # User secret
        (time/3600)+($hour_offset||0);          # Time limitation
}


# Returns 1 if the given CSRF token is still valid (meaning: created for this
# user within the past 3 hours), 0 otherwise.
sub csrfcheck {
    my($self, $token) = @_;
    return 1 if $self->csrftoken( 0) eq $token;
    return 1 if $self->csrftoken(-1) eq $token;
    return 1 if $self->csrftoken(-2) eq $token;
    return 0;
}


# TODO: Measure global usage of the pref() and prefSet() calls to see if this cache is actually necessary.

my @pref_columns = qw/
    email_confirmed skin customcss filter_vn filter_release show_nsfw hide_list notify_dbedit notify_announce
    vn_list_own vn_list_wish tags_all tags_cont tags_ero tags_tech spoilers traits_sexual
/;

# Returns a user preference column for the current user. Lazily loads all
# preferences to speed of subsequent calls.
sub pref {
    my($self, $key) = @_;
    return undef if !$self->uid;

    $self->{pref} ||= tuwf->dbRowi('SELECT', sql_comma(map "\"$_\"", @pref_columns), 'FROM users WHERE id =', \$self->uid);
    $self->{pref}{$key};
}


sub prefSet {
    my($self, $key, $value, $uid) = @_;
    die "Unknown pref key: $_" if !grep $key eq $_, @pref_columns;
    $uid //= $self->uid;
    $self->{pref}{$key} = $value;
    tuwf->dbExeci(qq{UPDATE users SET "$key" =}, \$value, 'WHERE id =', \$self->uid);
}


1;