--- /dev/null
+package PciIds::Address;
+use strict;
+use warnings;
+use PciIds::Address::Pci;
+use PciIds::Address::PciClass;
+
+sub new( $ ) {
+ my( $address ) = @_;
+ $address =~ s/\/(mods|read|static)//;#Eat the prefix
+ $address =~ s/\/$//;
+ $address =~ s/^\///;
+ if( $address =~ /^PC/ ) {
+ return PciIds::Address::Pci::new( $address );
+ } elsif( $address =~ /^PD/ ) {
+ return PciIds::Address::PciClass::new( $address );
+ } else {
+ return undef;
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Address::Base;
+use strict;
+use warnings;
+use PciIds::Address;
+
+sub new( $ ) {
+ return bless {
+ 'value' => shift
+ }
+}
+
+sub get( $ ) {
+ return shift->{'value'};
+}
+
+sub parent( $ ) {
+ my( $new ) = ( shift->get() );
+ $new =~ s/[^\/]+\/?$//;
+ return PciIds::Address::new( $new );
+}
+
+sub tail( $ ) {
+ my( $new ) = ( shift->get() );
+ $new =~ s/.*\/(.)/$1/;
+ return $new;
+}
+
+sub canAddComment( $ ) {
+ return 1; #By default, comments can be added anywhere
+}
+
+sub canAddItem( $ ) { return !shift->leaf(); }
+
+sub defaultRestrict( $ ) { return "" };
+
+sub defaultRestrictList( $ ) { return [] };
+
+1;
--- /dev/null
+package PciIds::Address::Pci;
+use strict;
+use warnings;
+use PciIds::Address::Toplevel;
+use base 'PciIds::Address::Base';
+
+sub new( $ ) {
+ my( $address ) = @_;
+ return PciIds::Address::Toplevel::new( $address ) if( $address =~ /^PC\/?$/ );
+ return bless PciIds::Address::Base::new( $address );
+}
+
+sub pretty( $ ) {
+ my $self = shift;
+ $_ = $self->get();
+ s/^PC\/?//;
+ s/\//:/g;
+ s/([0-9a-f]{4,4})([0-9a-f]{4,4})/$1 $2/g;
+ my $prefix = '';
+ if( /:.*:/ ) {
+ $prefix = 'Subsystem';
+ } elsif( /:/ ) {
+ $prefix = 'Device';
+ } else {
+ $prefix = 'Vendor';
+ }
+ return $prefix.' '. $_;
+}
+
+sub tail( $ ) {
+ my( $new ) = ( shift->get() );
+ $new =~ s/.*\/(.)/$1/;
+ $new =~ s/([0-9a-f]{4,4})([0-9a-f]{4,4})/$1 $2/g;
+ return $new;
+}
+
+sub restrictRex( $$ ) {
+ my( $self, $restrict ) = @_;
+ my( $result ) = ( $restrict =~ /^([a-f0-9]{1,4})/ );#TODO every time?
+ return $result;
+}
+
+sub leaf( $ ) {
+ return ( shift->get() =~ /\/.*\/.*\// );
+}
+
+sub append( $$ ) {
+ my( $self, $suffix ) = @_;
+ return ( undef, 'You can not add to leaf node' ) if( $self->leaf() );
+ $suffix =~ s/ //g;
+ return ( undef, "Invalid ID syntax" ) unless ( ( ( $self->get() !~ /^PC\/.*\// ) && ( $suffix =~ /^[0-9a-f]{4}$/ ) ) || ( ( $self->get() =~ /^PC\/.*\// ) && ( $suffix =~ /^[0-9a-f]{8}$/ ) ) );
+ return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
+}
+
+1;
--- /dev/null
+package PciIds::Address::PciClass;
+use strict;
+use warnings;
+use PciIds::Address::Toplevel;
+use base 'PciIds::Address::Base';
+
+sub new( $ ) {
+ my( $address ) = @_;
+ return PciIds::Address::Toplevel::new( $address ) if( $address =~ /^PD\/?$/ );
+ return bless PciIds::Address::Base::new( $address );
+}
+
+sub pretty( $ ) {
+ my $self = shift;
+ $_ = $self->get();
+ s/^PD\/?//;
+ s/\//:/g;
+ my $prefix;
+ if( /:.*:/ ) {
+ $prefix = 'Program interface';
+ } elsif( /:/ ) {
+ $prefix = 'Device subclass';
+ } else {
+ $prefix = 'Device class';
+ }
+ #TODO Other levels? Are the names OK?
+ return $prefix.' '.$_;
+}
+
+sub restrictRex( $$ ) {
+ my( $self, $restrict ) = @_;
+ my( $result ) = ( $restrict =~ /^([a-f0-9]{1,4})/ );#TODO every time?
+ return $result;
+}
+
+sub leaf( $ ) {
+ #TODO
+}
+
+sub append( $$ ) {
+ my( $self, $suffix ) = @_;
+ return ( undef, 'You can not add to leaf node' ) if( $self->leaf() );
+ return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{2,2}$/ );
+ return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
+}
+
+1;
--- /dev/null
+package PciIds::Address::Toplevel;
+use strict;
+use warnings;
+use base 'PciIds::Address::Base';
+
+sub new( $ ) {
+ my( $value ) = @_;
+ if( $value =~ /^P[CD]\/?/ ) {
+ return bless PciIds::Address::Base::new( $value );
+ } else {
+ return undef;
+ }
+}
+
+sub pretty( $ ) {
+ my $self = shift;
+ if( $self->{'value'} =~ /^PC/ ) {
+ return 'PCI Devices';
+ } else {
+ return 'PCI Device Classes';
+ }
+}
+
+sub restrictRex( $$ ) {
+ my( $self, $restrict ) = @_;
+ return PciIds::Address::new( $self->get().'/0000' )->restrictRex( $restrict );#Nasty trick, get the right address of any subnode and try it there
+}
+
+sub leaf( $ ) {
+ return 0;
+}
+
+sub append( $$ ) {
+ my( $self, $suffix ) = @_;
+ $suffix = lc $suffix;
+ if( $self->{'value'} =~ /^PC/ ) {#PCI
+ return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{4,4}$/ );
+ } else {#PCI Device Class
+ return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{2,2}$/ );
+ }
+ return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
+}
+
+sub canAddComment( $ ) { return 0; }
+
+sub defaultRestrict( $ ) {
+ my( $self ) = @_;
+ if( $self->get() =~ /PC/ ) {
+ return "0";
+ } else {
+ return "";
+ }
+}
+
+sub defaultRestrictList( $ ) {
+ my( $self ) = @_;
+ if( $self->get() =~ /PC/ ) {
+ my @result;
+ for(my $i = '0'; $i < '10'; ++ $i ) {
+ push @result, $i;
+ }
+ push @result, ( 'a', 'b', 'c', 'd', 'e', 'f' );
+ my @final;
+ push @final, [ $_, $_ ] foreach( @result );
+ push @final, [ "", "all" ];
+ return \@final;
+ } else {
+ return [];
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Config;
+use strict;
+use warnings;
+use Startup;
+use base 'Exporter';
+
+our @EXPORT = qw(&checkConf &defConf %config &confList);
+
+our %config;
+
+sub loadConf() {
+ open CONFIG, $directory."/config" or die "Config file not found. Make sure config is in the directory and the correct path is in Startup.pm\n";
+ foreach( <CONFIG> ) {
+ next if( /^\s*(|#.*)$/ );
+ chomp;
+ my( $name, $val );
+ die "Invalid syntax on line $_\n" unless( ( $name, $val ) = /^\s*(.*\S)\s*=\s*(.*\S)\s*$/ );
+ $val =~ s/^"(.*)"$/$1/;
+ $config{$name} = $val;
+ }
+ close CONFIG;
+}
+
+sub checkConf( $ ) {
+ my( $names ) = @_;
+ foreach( @{$names} ) {
+ die "Variable not set: $_\n" unless( defined $config{$_} );
+ }
+}
+
+sub defConf( $ ) {
+ my( $underlay ) = @_;
+ foreach( keys %{$underlay} ) {
+ $config{$_} = $underlay->{$_} unless( defined $config{$_} );
+ }
+}
+
+sub confList( $ ) {
+ my( $names ) = @_;
+ my( @result );
+ push @result, $config{$_} foreach( @{$names} );
+ return( @result );
+}
+
+loadConf();
+
+return 1;
--- /dev/null
+package PciIds::DBQ;
+use strict;
+use warnings;
+use base 'PciIds::DBQAny';
+
+sub new( $ ) {
+ my( $dbh ) = @_;
+ my $node = 'SELECT id, name, description, maincomment FROM locations WHERE parent = ? ORDER BY ';
+ my $noder = 'SELECT id, name, description, maincomment FROM locations WHERE parent = ? AND id LIKE ? ORDER BY ';
+ return bless PciIds::DBQAny::new( $dbh, {
+ 'nodes-id' => $node.'id',
+ 'nodes-name' => $node.'name',
+ 'nodes-rid' => $node.'id DESC',
+ 'nodes-rname' => $node.'name DESC',
+ 'nodes-id-r' => $noder.'id',
+ 'nodes-name-r' => $noder.'name',
+ 'nodes-rid-r' => $noder.'id DESC',
+ 'nodes-rname-r' => $noder.'name DESC',
+ 'item' => 'SELECT parent, name, description, maincomment FROM locations WHERE id = ?',
+ 'login' => 'SELECT id FROM users WHERE login = ?',
+ 'email' => 'SELECT id FROM users WHERE email = ?',
+ 'adduser' => 'INSERT INTO users (login, email, passwd) VALUES(?, ?, ?)',
+ 'adduser-null' => 'INSERT users (email, passwd) VALUES(?, ?)',
+ 'loginfomail' => 'SELECT id, passwd, logtime, lastlog FROM users WHERE email = ?',
+ 'loginfoname' => 'SELECT id, passwd, logtime, lastlog, email FROM users WHERE login = ?',
+ 'resetinfo' => 'SELECT id, login, passwd FROM users WHERE email = ?',
+ 'changepasswd' => 'UPDATE users SET passwd = ? WHERE id = ?',
+ 'setlastlog' => 'UPDATE users SET logtime = now(), lastlog = ? WHERE id = ?',
+ 'rights' => 'SELECT rightId FROM rights WHERE userId = ?',
+ 'newitem' => 'INSERT INTO locations (id, parent) VALUES(?, ?)',
+ 'newcomment' => 'INSERT INTO history (location, owner, text, nodename, nodedescription) VALUES(?, ?, ?, ?, ?)',
+ 'history' => 'SELECT history.id, history.text, history.time, history.nodename, history.nodedescription, history.seen, users.login FROM history LEFT OUTER JOIN users ON history.owner = users.id WHERE history.location = ? ORDER BY history.time',
+ 'admindump' => 'SELECT
+ locations.id, locations.name, locations.description, locations.maincomment, musers.login, main.text,
+ history.id, history.text, history.nodename, history.nodedescription, users.login
+ FROM
+ locations INNER JOIN history ON history.location = locations.id
+ LEFT OUTER JOIN users ON history.owner = users.id
+ LEFT OUTER JOIN history AS main ON locations.maincomment = main.id
+ LEFT OUTER JOIN users AS musers ON main.owner = musers.id WHERE history.seen = "0"
+ ORDER BY locations.id, history.id
+ LIMIT 15',#Dumps all new comments with their senders and corresponding main comments and names
+ 'delete-hist' => 'DELETE FROM history WHERE id = ?',
+ 'mark-checked' => 'UPDATE history SET seen = 1 WHERE id = ?',
+ 'delete-item' => 'DELETE FROM locations WHERE id = ?',
+ 'set-maincomment' => 'UPDATE locations SET
+ maincomment = ?,
+ name = ( SELECT nodename FROM history WHERE id = ? ),
+ description = ( SELECT nodedescription FROM history WHERE id = ? )
+ WHERE
+ id = ?',
+ 'profiledata' => 'SELECT email, xmpp, login, mailgather, xmppgather FROM users WHERE id = ?',
+ 'pushprofile' => 'UPDATE users SET xmpp = ?, login = ?, mailgather = ?, xmppgather = ? WHERE id = ?',
+ 'setemail' => 'UPDATE users SET email = ?, passwd = ? WHERE id = ?',
+ 'notifuser' => 'SELECT location, recursive FROM notifications WHERE user = ? ORDER BY location',
+ 'notifdata' => 'SELECT recursive, type, notification FROM notifications WHERE user = ? AND location = ?',
+ 'drop-notif' => 'DELETE FROM notifications WHERE user = ? AND location = ?',
+ 'new-notif' => 'INSERT INTO notifications (user, location, recursive, type, notification) VALUES (?, ?, ?, ?, ?)',
+ 'notify' => 'INSERT INTO pending (user, comment, notification, reason) SELECT DISTINCT user, ?, ?, ? FROM notifications WHERE ( notification = 2 OR notification = ? ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) )',
+ 'newtime-mail' => 'UPDATE users SET nextmail = FROM_UNIXTIME( UNIX_TIMESTAMP( NOW() ) + 60 * mailgather ) WHERE nextmail < NOW() AND EXISTS ( SELECT 1 FROM notifications WHERE ( notification = 0 OR notification = 2 ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) ) )',
+ 'newtime-xmpp' => 'UPDATE users SET nextxmpp = FROM_UNIXTIME( UNIX_TIMESTAMP( NOW() ) + 60 * xmppgather ) WHERE nextxmpp < NOW() AND EXISTS ( SELECT 1 FROM notifications WHERE ( notification = 1 OR notification = 2 ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) ) )',
+ 'mailout' => 'SELECT
+ pending.user, users.email,
+ pending.reason, history.text, history.nodename, history.nodedescription, history.time,
+ auth.login, history.location, locations.name, locations.description
+ FROM
+ pending
+ INNER JOIN users ON users.id = pending.user
+ INNER JOIN history ON history.id = pending.comment
+ INNER JOIN locations ON history.location = locations.id
+ INNER JOIN users AS auth ON auth.id = history.owner
+ WHERE
+ pending.notification = 0
+ AND users.nextmail <= ?
+ ORDER BY
+ pending.user, pending.reason, history.time, history.location',
+ 'xmppout' => 'SELECT
+ pending.user, users.xmpp,
+ pending.reason, history.text, history.nodename, history.nodedescription, history.time,
+ auth.login, history.location, locations.name, locations.description
+ FROM
+ pending
+ INNER JOIN users ON users.id = pending.user
+ INNER JOIN history ON history.id = pending.comment
+ INNER JOIN locations ON history.location = locations.id
+ INNER JOIN users AS auth ON auth.id = history.owner
+ WHERE
+ pending.notification = 1
+ AND users.nextxmpp <= ?
+ ORDER BY
+ pending.user, pending.reason, history.time, history.location',
+ 'dropnotifsxmpp' => 'DELETE FROM pending WHERE notification = 1 AND EXISTS ( SELECT 1 FROM users WHERE users.id = pending.user AND nextxmpp <= ? )',
+ 'dropnotifsmail' => 'DELETE FROM pending WHERE notification = 0 AND EXISTS ( SELECT 1 FROM users WHERE users.id = pending.user AND nextmail <= ? )',
+ 'time' => 'SELECT NOW()'
+
+ } );
+}
+
+my %sorts = ( 'id' => 1, 'rid' => 1, 'name' => 1, 'rname' => 1 );
+
+sub nodes( $$$$ ) {
+ my( $self, $parent, $args, $restrict ) = @_;
+ my $q = 'id';
+ $q = $args->{'sort'} if( defined( $args->{'sort'} ) && defined( $sorts{$args->{'sort'}} ) );
+ if( defined( $restrict ) && ( $restrict ne "" ) ) {
+ return $self->query( 'nodes-'.$q.'-r', [ $parent, $parent.'/'.$restrict.'%' ] );
+ } else {
+ return $self->query( 'nodes-'.$q, [ $parent ] );
+ }
+}
+
+sub item( $$ ) {
+ my( $self, $id ) = @_;
+ my $result = $self->query( "item", [ $id ] );
+ if( scalar @{$result} ) {
+ return $result->[ 0 ];
+ } else {
+ return undef;
+ }
+}
+
+sub hasLogin( $$ ) {
+ my( $self, $login ) = @_;
+ my $result = $self->query( 'login', [ $login ] );
+ return scalar @{$result};
+}
+
+sub hasEmail( $$ ) {
+ my( $self, $email ) = @_;
+ my $result = $self->query( 'email', [ $email ] );
+ return scalar @{$result};
+}
+
+sub addUser( $$$$ ) {
+ my( $self, $login, $email, $passwd ) = @_;
+ eval {
+ if( ( defined $login ) && ( $login ne '' ) ) {
+ $self->command( 'adduser', [ $login, $email, $passwd ] );
+ } else {
+ $self->command( 'adduser-null', [ $email, $passwd ] );
+ }
+ };
+ if( $@ ) {
+ return 0;
+ } else {
+ return $self->last();
+ }
+}
+
+sub getLogInfo( $$ ) {
+ my( $self, $info ) = @_;
+ my $data;
+ if( $info =~ /@/ ) {#An email address
+ $data = $self->query( 'loginfomail', [ $info ] );
+ } else {
+ $data = $self->query( 'loginfoname', [ $info ] );
+ }
+ if( scalar @{$data} ) {
+ my( $id, $passwd, $logtime, $lastlog, $email ) = @{$data->[ 0 ]};
+ my $logstring;
+ $logstring = "Last logged from $lastlog at $logtime" if( defined $logtime && defined $lastlog );
+ $email = $info if( $info =~ /@/ );
+ return( $id, $passwd, $email, $logstring );
+ } else {
+ return undef;
+ }
+}
+
+sub rights( $$ ) {
+ my( $self, $id ) = @_;
+ return $self->query( 'rights', [ $id ] );
+}
+
+sub setLastLog( $$$ ) {
+ my( $self, $id, $from ) = @_;
+ $self->command( 'setlastlog', [ $from, $id ] );
+}
+
+sub history( $$ ) {
+ my( $self, $addr ) = @_;
+ return $self->query( 'history', [ $addr ] );
+}
+
+sub submitItem( $$$ ) {
+ my( $self, $data, $auth ) = @_;
+ my( $addr ) = ( $data->{'address'} );
+ return( 'exists', undef ) if( defined( $self->item( $addr->get(), 0 ) ) );
+ eval {
+ $self->command( 'newitem', [ $addr->get(), $addr->parent()->get() ] );
+ $self->command( 'newcomment', [ $addr->get(), $auth->{'authid'}, $data->{'text'}, $data->{'name'}, $data->{'description'} ] );
+
+ };
+ if( $@ ) {
+ $self->rollback();
+ return( 'internal: '.$@, undef );
+ }
+ return( '', $self->last() );
+}
+
+sub submitComment( $$$$ ) {
+ my( $self, $data, $auth, $address ) = @_;
+ $self->command( 'newcomment', [ $address->get(), $auth->{'authid'}, $data->{'text'}, $data->{'name'}, $data->{'description'} ], 1 );
+ return $self->last();
+}
+
+sub adminDump( $ ) {
+ return shift->query( 'admindump', [] );
+}
+
+sub deleteHistory( $$ ) {
+ my( $self, $id ) = @_;
+ $self->command( 'delete-hist', [ $id ] );
+}
+
+sub markChecked( $$ ) {
+ my( $self, $id ) = @_;
+ $self->command( 'mark-checked', [ $id ] );
+}
+
+sub deleteItem( $$ ) {
+ my( $self, $id ) = @_;
+ $self->command( 'delete-item', [ $id ] );
+}
+
+sub setMainComment( $$$ ) {
+ my( $self, $location, $comment ) = @_;
+ $self->command( 'set-maincomment', [ $comment, $comment, $comment, $location ] );
+}
+
+sub resetInfo( $$ ) {
+ my( $self, $mail ) = @_;
+ my $result = $self->query( 'resetinfo', [ $mail ] );
+ if( scalar @{$result} ) {
+ return ( @{$result->[0]} );
+ } else {
+ return undef;
+ }
+}
+
+sub changePasswd( $$$ ) {
+ my( $self, $id, $passwd ) = @_;
+ $self->command( 'changepasswd', [ $passwd, $id ] );
+}
+
+sub profileData( $$ ) {
+ my( $self, $id ) = @_;
+ my %result;
+ ( $result{'email'}, $result{'xmpp'}, $result{'login'}, $result{'email_time'}, $result{'xmpp_time'} ) = @{$self->query( 'profiledata', [ $id ] )->[0]};
+ return \%result;
+}
+
+sub setEmail( $$$$ ) {
+ my( $self, $id, $email, $passwd ) = @_;
+ $self->command( 'setemail', [ $email, $passwd, $id ] );
+}
+
+sub pushProfile( $$$$$$ ) {
+ my( $self, $id, $login, $xmpp, $mailgather, $xmppgather ) = @_;
+ $self->command( 'pushprofile', [ $xmpp, $login, $mailgather, $xmppgather, $id ] );
+}
+
+sub notificationsUser( $$ ) {
+ my( $self, $uid ) = @_;
+ return $self->query( 'notifuser', [ $uid ] );
+}
+
+sub getNotifData( $$$ ) {
+ my( $self, $uid, $location ) = @_;
+ my $result = $self->query( 'notifdata', [ $uid, $location ] );
+ if( @{$result} ) {
+ my( $recursive, $notification, $way ) = @{$result->[0]};
+ return {
+ 'recursive' => $recursive,
+ 'notification' => $notification,
+ 'way' => $way };
+ } else {
+ return { 'recursive' => 1 };
+ }
+}
+
+sub submitNotification( $$$$ ) {
+ my( $self, $uid, $location, $data ) = @_;
+ $self->command( 'drop-notif', [ $uid, $location ] );
+ $self->command( 'new-notif', [ $uid, $location, $data->{'recursive'}, $data->{'notification'}, $data->{'way'} ] ) unless( $data->{'notification'} == 3 );
+}
+
+sub pushNotifications( $$$$$ ) {
+ my( $self, $location, $comment, $priority, $reason ) = @_;
+ $self->command( 'notify', [ $comment, 0, $reason, 0, $priority, $location, $location ] );
+ $self->command( 'notify', [ $comment, 1, $reason, 1, $priority, $location, $location ] );
+ $self->command( 'newtime-mail', [ $priority, $location, $location ] );
+ $self->command( 'newtime-xmpp', [ $priority, $location, $location ] );
+}
+
+sub mailNotifs( $$ ) {
+ my( $self, $time ) = @_;
+ return $self->query( 'mailout', [ $time ] );
+}
+
+sub xmppNotifs( $$ ) {
+ my( $self, $time ) = @_;
+ return $self->query( 'xmppout', [ $time ] );
+}
+
+sub time( $ ) {
+ my( $self ) = @_;
+ return $self->query( 'time', [] )->[0]->[0];
+}
+
+sub dropNotifs( $$ ) {
+ my( $self, $time ) = @_;
+ $self->command( 'dropnotifsmail', [ $time ] );
+ $self->command( 'dropnotifsxmpp', [ $time ] );
+}
+
+1;
--- /dev/null
+package PciIds::DBQAny;
+use strict;
+use warnings;
+use DBI;
+
+sub new( $$ ) {
+ my( $dbh, $queries ) = @_;
+ my %qs;
+ foreach( keys %{$queries} ) {
+ $qs{$_} = $dbh->prepare( $queries->{$_} );
+ }
+ return bless {
+ "dbh" => $dbh,
+ "queries" => \%qs
+ };
+}
+
+sub queryAll( $$$$ ) {
+ my( $self, $name, $params, $fetch ) = @_;
+ my $q = $self->{'queries'}->{$name};
+ $q->execute( @{$params} );#Will die automatically
+ if( $fetch ) {
+ my @result = @{$q->fetchall_arrayref()};#Copy the array, finish() deletes the content
+ $q->finish();
+ return \@result;
+ }
+}
+
+sub query( $$$ ) {
+ my( $self, $name, $params ) = @_;
+ return queryAll( $self, $name, $params, 1 );
+}
+
+sub command( $$$ ) {
+ my( $self, $name, $params ) = @_;
+ queryAll( $self, $name, $params, 0 );
+}
+
+sub commit( $ ) {
+ shift->{'dbh'}->commit();
+}
+
+sub rollback( $ ) {
+ shift->{'dbh'}->rollback();
+}
+
+sub last( $ ) {
+ return shift->{'dbh'}->last_insert_id( undef, undef, undef, undef );
+}
+
+sub dbh( $ ) { return shift->{'dbh'}; }
+
+1;
--- /dev/null
+package PciIds::Db;
+use strict;
+use warnings;
+use base 'Exporter';
+use PciIds::Config;
+use DBI;
+
+our @EXPORT = qw( &connectDb );
+
+sub connectDb() {
+ my ( $uri, $user, $passwd ) = confList( [ "dburi", "dbuser", "dbpasswd" ] );
+ my $result = DBI->connect( $uri, $user, $passwd, { 'AutoCommit' => 0, 'RaiseError' => 1, 'PrintError' => 0 } ) or die "Could not connect to database $uri (".DBI->errstr.")\n";
+}
+
+checkConf( [ "dbuser", "dbpasswd" ] );
+defConf( { "dbname" => "pciids" } );
+defConf( { "dburi" => "dbi:mysql:".$config{"dbname"} } );
+
+return 1;
--- /dev/null
+package PciIds::Email;
+use strict;
+use warnings;
+use PciIds::Config;
+use base 'Exporter';
+
+our @EXPORT = qw(&sendMail);
+
+checkConf( [ 'from_addr', 'sendmail' ] );
+defConf( { 'sendmail' => '/usr/sbin/sendmail' } );
+
+sub sendMail( $$$ ) {
+ my( $to, $subject, $body ) = @_;
+ my( $from, $sendmail ) = confList( [ 'from_addr', 'sendmail' ] );
+ $body =~ s/^\.$/../gm;
+ open SENDMAIL, "|$sendmail -f$from $to" or die 'Can not send mail';
+ print SENDMAIL "From: $from\n".
+ "To: $to\n".
+ "Subject: $subject\n".
+ "Content-Type: text/plain; charset=\"utf8\"\n".
+ "\n".
+ $body."\n.\n";
+ close SENDMAIL or die "Sending mail failed: $!, $?";
+}
+
+1;
--- /dev/null
+package PciIds::Html::Admin;
+use strict;
+use warnings;
+use PciIds::Users;
+use PciIds::Html::Util;
+use PciIds::Html::Users;
+use PciIds::Html::Forms;
+use PciIds::Notifications;
+use PciIds::Log;
+use Apache2::Const qw(:common :http);
+
+sub genNewAdminForm( $$$$ ) {
+ my( $req, $args, $tables, $error ) = @_;
+ genHtmlHead( $req, 'Administration ‒ pending events', undef );
+ print "<h1>Administration ‒ pending events</h1>\n";
+ print "<div class='error'>".$error."</div>\n" if( defined $error );
+ print '<form name="admin" id="admin" class="admin" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args )."?action=admin\">\n";
+ my $lastId;
+ my $started = 0;
+ my $cnt = 0;
+ my $hiscnt = 0;
+ my $subcnt;
+ foreach( @{$tables->adminDump()} ) {
+ my( $locId, $actName, $actDescription, $actCom, $actUser, $actText,
+ $com, $text, $name, $description, $user ) = @{$_};
+ if( !defined( $lastId ) || ( $lastId ne $locId ) ) {
+ $lastId = $locId;
+ print "</div>\n" if( $started );
+ $started = 1;
+ print "<div class='".( defined( $actCom ) ? 'item' : 'unnamedItem' )."'>\n";
+ my $addr = PciIds::Address::new( $locId );
+ print "<h3><a href='/read/".$addr->get()."/'>".encode( $addr->pretty() )."</a></h3>\n";
+ print htmlDiv( 'name', '<p>'.encode( $actName ) ) if( defined( $actName ) );
+ print htmlDiv( 'description', '<p>'.encode( $actDescription ) ) if( defined( $actDescription ) );
+ print '<p>'.encode( $actText ) if( defined( $actText ) );
+ print '<p><a class="navigation" href="/read/'.$addr->parent()->get().'/">'.encode( $addr->parent()->pretty() )."</a>" if( defined( $addr->parent() ) );
+ print htmlDiv( 'author', '<p>'.encode( $actUser ) ) if( defined( $actUser ) );
+ print "<input type='hidden' name='subcnt-$cnt' value='$subcnt'>\n" if( defined( $subcnt ) );
+ $subcnt = 0;
+ $cnt++;
+ print "<input type='hidden' name='loc-$cnt' value='".$addr->get()."'>\n";
+ print "<p><input type='radio' name='action-$cnt' value='ignore' checked='checked'> I will decide later.\n";
+ if( defined( $actCom ) ) {
+ print "<br><input type='radio' name='action-$cnt' value='keep'> Keep current name.\n";
+ }
+ print "<br><input type='radio' name='action-$cnt' value='delete'> Delete item.\n";
+ print "<br>Add comment:\n";
+ print "<br><table>\n";
+ print "<tr><td>Set name:<td><input type='text' name='name-$cnt' maxlength='200'>\n";
+ print "<tr><td>Set description:<td><input type='text' name='description-$cnt' maxlength='1024'>\n";
+ print "<tr><td>Text:<td><textarea name='text-$cnt' rows='2'></textarea>\n";
+ print "</table>\n";
+ }
+ print "<div class='unseen-comment'>\n";
+ print "<p class='name'>".encode( $name ) if( defined( $name ) );
+ print "<p class='description'>".encode( $description ) if( defined( $description ) );
+ print '<p>'.encode( $text ) if( defined( $text ) );
+ print "<p class='author'>".encode( $user ) if( defined( $user ) );
+ print "<p><input type='radio' name='action-$cnt' value='set-$com'> Use this one.\n" if( defined( $name ) && ( $name ne "" ) );
+ $hiscnt ++;
+ print "<br><input type='checkbox' name='delete-$hiscnt' value='delete-$com'> Delete comment.\n";
+ print "</div>\n";
+ $subcnt ++;
+ print "<input type='hidden' name='sub-$cnt-$subcnt' value='$com'>\n";
+ }
+ print "<input type='hidden' name='subcnt-$cnt' value='$subcnt'>\n" if( defined( $subcnt ) );
+ if( $started ) {
+ print "</div>\n" if( $started );
+ print "<p><input type='submit' name='submit' value='Submit'>\n";
+ print "<input type='hidden' name='max-cnt' value='$cnt'><input type='hidden' name='max-hiscnt' value='$hiscnt'>\n";
+ } else {
+ print "<p>No pending comments.\n";
+ }
+ print "</form>\n";
+ genHtmlTail();
+ return OK;
+}
+
+sub adminForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined( $auth->{'authid'} ) && hasRight( $auth->{'accrights'}, 'validate' ) ) {
+ return genNewAdminForm( $req, $args, $tables, undef );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+sub markAllChecked( $$$$ ) {
+ my( $tables, $itemNum, $deleted, $authid ) = @_;
+ my $i;
+ my $subcnt = getFormValue( "subcnt-$itemNum", 0 );
+ for( $i = 1; $i <= $subcnt; ++ $i ) {
+ my $id = getFormValue( "sub-$itemNum-$i", undef );
+ next unless( defined( $id ) );
+ next if( $deleted->{$id} );#Do not update this one, already deleted
+ $tables->markChecked( $id );
+ tulog( $authid, "Comment checked $id" );
+ }
+}
+
+sub submitAdminForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ my $authid = $auth->{'authid'};
+ if( defined( $authid ) && hasRight( $auth->{'accrights'}, 'validate' ) ) {
+ my $errors = '';
+ my %deleted;
+ my $maxcnt = getFormValue( 'max-cnt', 0 );
+ my $maxhiscnt = getFormValue( 'max-hiscnt', 0 );
+ for( my $i = 1; $i <= $maxhiscnt; $i ++ ) {
+ my $del = getFormValue( "delete-$i", "" );
+ $del =~ s/^delete-//;
+ if( $del ne '' ) {
+ $deleted{$del} = 1;
+ $tables->deleteHistory( $del );
+ tulog( $authid, "Comment deleted $del" );
+ }
+ }
+ for( my $i = 1; $i <= $maxcnt; $i ++ ) {
+ my $action = getFormValue( "action-$i", 'ignore' );
+ my $loc = getFormValue( "loc-$i", undef );
+ next unless( defined( $loc ) );
+ my( $text, $name, $description ) = (
+ getFormValue( "text-$i", undef ),
+ getFormValue( "name-$i", undef ),
+ getFormValue( "description-$i", undef ) );
+ if( defined( $description ) && ( $description ne '' ) && ( !defined( $name ) || ( length $name < 3 ) ) ) {
+ if( $errors eq '' ) {
+ $errors = '<p>';
+ } else {
+ $errors .= '<br>';
+ }
+ $errors .= "$loc - You need to provide name if you provide description\n";
+ next;
+ }
+ if( ( defined( $name ) && ( length $name >= 3 ) ) || ( defined( $text ) && ( $text ne '' ) ) ) { #Submited comment
+ my $addr = PciIds::Address::new( $loc );
+ my $comId = $tables->submitComment( { 'name' => $name, 'description' => $description, 'explanation' => $text }, $auth, $addr );
+ my $main = defined $name && ( $name ne '' );
+ notify( $tables, $addr->get(), $comId, $main ? 2 : 0, $main ? 2 : 1 );
+ $tables->markChecked( $comId );
+ tulog( $authid, "Comment created (admin) $comId $loc ".logEscape( $name )." ".logEscape( $description )." ".logEscape( $text ) );
+ if( defined( $name ) && ( length $name >= 3 ) ) {
+ $tables->setMainComment( $loc, $comId );
+ tulog( $authid, "Item main comment changed $loc $comId" );
+ $action = 'keep';
+ }
+ }
+ next if( $action eq 'ignore' );
+ if( $action eq 'keep' ) {
+ markAllChecked( $tables, $i, \%deleted, $authid );
+ } elsif( $action eq 'delete' ) {
+ eval {
+ $tables->deleteItem( $loc );
+ tulog( $authid, "Item deleted (recursive) $loc" );
+ } #Ignore if it was already deleted by superitem
+ } elsif( my( $setId ) = ( $action =~ /set-(.*)/ ) ) {
+ next if( $deleted{$setId} );
+ $tables->setMainComment( $loc, $setId );
+ notify( $tables, $loc, $setId, 2, 2 );
+ tulog( $authid, "Item main comment changed $loc $setId" );
+ markAllChecked( $tables, $i, \%deleted, $authid );
+ }
+ }
+ return genNewAdminForm( $req, $args, $tables, $errors );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Html::Changes;
+use strict;
+use PciIds::Html::Users;
+use PciIds::Html::List;
+use PciIds::Html::Util;
+use PciIds::Html::Forms;
+use PciIds::Notifications;
+use PciIds::Log;
+use Apache2::Const qw(:common :http);
+
+sub genNewItemForm( $$$$$ ) {
+ my( $req, $args, $tables, $error, $values ) = @_;
+ my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
+ return NOT_FOUND unless( $ok );
+ my $prettyAddr = encode( $address->pretty() );
+ genHtmlHead( $req, "$prettyAddr - add new item", undef );
+ print "<h1>$prettyAddr - add new item</h1>\n";
+ print "<div class='error'>$error</div>\n" if( defined $error );
+ print "<form name='newitem' id='newitem' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=newitem'>\n<table>";
+ genFormEx( [ [ 'input', 'Id:', 'text', 'id', 'maxlength="50"' ],
+ [ 'input', 'Name:', 'text', 'name', 'maxlength="200"' ],
+ [ 'input', 'Description*:', 'text', 'description', 'maxlength="1024"' ],
+ [ 'textarea', 'Text*:', undef, 'text', 'rows="5" cols="50"' ],
+ [ 'input', '', 'submit', 'submit', 'value="Submit"' ] ], $values );
+ print '</table></form>';
+ print '<p>Items marked with * are optional.';
+ genHtmlTail();
+ return OK;
+}
+
+sub newItemForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined $auth->{'authid'} ) {#Logged in alright
+ return genNewItemForm( $req, $args, $tables, undef, {} );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+sub newItemSubmit( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined $auth->{'authid'} ) {
+ my( $pok, $parent, $pname, $pdescription, $paddress ) = loadItem( $tables, $req->uri() );
+ return NOT_FOUND unless( $pok );
+ my( $data, $error ) = getForm( {
+ 'id' => sub{ return ( length shift ) ? undef : 'Please, provide the ID'; }, #Checked at the bottom and added as address
+ 'name' => sub {
+ my( $name ) = @_;
+ return 'Too short for a name' if( length $name < 3 );
+ return 'Lenght limit of the name is 200 characters' if( length $name > 200 );
+ return undef;
+ },
+ 'description' => sub { return ( length shift > 1024 ) ? 'Description can not be longer than 1024 characters' : undef; },
+ 'text' => sub { return ( length shift > 1024 ) ? 'Text can not be longer than 1024 characters' : undef; }
+ }, [ sub { my( $data ) = @_;
+ my $errstr;
+ return undef unless( length $data->{'id'} );#No address, so let it for the first check
+ ( $data->{'address'}, $errstr ) = $paddress->append( $data->{'id'} );
+ return $errstr;
+ }, sub { return $paddress->canAddItem() ? undef : 'Can not add items here'; } ] );
+ return genNewItemForm( $req, $args, $tables, $error, $data ) if( defined $error );
+ my( $result, $comName ) = $tables->submitItem( $data, $auth );
+ if( $result eq 'exists' ) {
+ genHtmlHead( $req, 'ID collision', undef );
+ print '<h1>ID collision</h1>';
+ print '<p>This ID already exists. Have a look <a href="/read/'.$data->{'address'}->get().'?action=list">at it</a>';
+ genHtmlTail();
+ return OK;
+ } elsif( $result ) {
+ die "Failed to submit new item: $result\n";
+ }
+ notify( $tables, $data->{'address'}->get(), $comName, 2, 0 );
+ tulog( $auth->{'authid'}, "Item created ".$data->{'address'}->get()." ".logEscape( $data->{'name'} )." ".logEscape( $data->{'description'} )." ".logEscape( $data->{'text'} )." $comName" );
+ return HTTPRedirect( $req, '/read/'.$data->{'address'}->get().'?action=list' );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+sub genNewCommentForm( $$$$$ ) {
+ my( $req, $args, $tables, $error, $values ) = @_;
+ my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
+ return NOT_FOUND unless( $ok );
+ my $prettyAddr = encode( $address->pretty() );
+ genHtmlHead( $req, "$prettyAddr - add a comment to discussion", undef );
+ print "<h1>$prettyAddr - add a comment to discussion</h1>\n";
+ print "<div class='error'>$error</div>\n" if( defined $error );
+ print "<form name='newcomment' id='newitem' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=newcomment'>\n<table>";
+ genFormEx( [ [ 'textarea', 'Text:', undef, 'text', 'rows="5" cols="50"' ],
+ [ 'input', 'Name*:', 'text', 'name', 'maxlength="200"' ],
+ [ 'input', 'Description*:', 'text', 'description', 'maxlength="1024"' ],
+ [ 'input', '', 'submit', 'submit', 'value="Submit"' ] ], $values );
+ print '</table></form>';
+ print '<p>Items marked with * are optional, use them only if you want to change the name and description.';
+ print '<p>If you specify description must include name too.';
+ genHtmlTail();
+ return OK;
+}
+
+sub newCommentForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined $auth->{'authid'} ) {
+ return genNewCommentForm( $req, $args, $tables, undef, {} );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+sub newCommentSubmit( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined $auth->{'authid'} ) {
+ my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
+ return NOT_FOUND unless( $ok );
+ my( $data, $error ) = getForm( {
+ 'name' => sub { return ( length shift > 200 ) ? 'Lenght limit of the name is 200 characters' : undef; },
+ 'description' => sub { return ( length shift > 1024 ) ? 'Description can not be longer than 1024 characters' : undef; },
+ 'text' => sub {
+ my( $expl ) = @_;
+ return 'Text can not be longer than 1024 characters' if ( length $expl > 1024 );
+ return 'You must provide the text of comment' unless( length $expl );
+ return undef;
+ }
+ }, [ sub { my( $data ) = @_;
+ return 'You must provide name too' if( ( length $data->{'description'} ) && ( ! length $data->{'name'} ) );
+ return undef;
+ }, sub { return $address->canAddComment() ? undef : 'You can not discuss this item'; } ] );
+ return genNewCommentForm( $req, $args, $tables, $error, $data ) if( defined $error );
+ my $hid = $tables->submitComment( $data, $auth, $address );
+ tulog( $auth->{'authid'}, "Comment created $hid ".$address->get()." ".logEscape( $data->{'name'} )." ".logEscape( $data->{'description'} )." ".logEscape( $data->{'text'} ) );
+ notify( $tables, $address->get(), $hid, ( defined $name && ( $name ne '' ) ) ? 1 : 0, 1 );
+ return HTTPRedirect( $req, '/read/'.$address->get().'?action=list' );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Html::Debug;
+use strict;
+use warnings;
+use Apache2::Const qw(:common :http);
+use PciIds::Html::Util;
+
+sub test( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ genHtmlHead( $req, 'Test', undef );
+ print '<p>Logged in: '.$auth->{'authid'} if( defined $auth->{'authid'} );
+ print $auth->{'logerror'} if( defined $auth->{'logerror'} );
+ return OK unless defined $auth->{'authid'};
+ print "<p>";
+ foreach( keys %ENV ) {
+ print encode( "$_: $ENV{$_}<br>" );
+ }
+ genHtmlTail();
+ return OK;
+}
+
+1;
--- /dev/null
+package PciIds::Html::Format;
+use strict;
+use warnings;
+use PciIds::Html::Util;
+use base 'Exporter';
+
+our @EXPORT = qw(&htmlFormatTable);
+
+sub htmlFormatTable( $$$$$$ ) {
+ my( $data, $cols, $headers, $funcs, $filter, $trHead ) = @_;
+ $trHead = sub { return ''; } unless( defined $trHead );
+ foreach my $line ( @{$data} ) {
+ next unless( &{$filter}( $line ) );
+ my $i;
+ print '<tr'.&{$trHead}( $line ).'>';
+ for( $i = 0; $i < $cols; $i ++ ) {
+ my( $header, $func );
+ if( ( scalar( @{$headers} ) > $i ) && defined( $headers->[ $i ] ) ) {
+ $header = $headers->[ $i ];
+ } else {
+ $header = '<td>';
+ }
+ if( ( scalar( @{$funcs} ) > $i ) && defined( $funcs->[ $i ] ) ) {
+ $func = $funcs->[ $i ];
+ } else {
+ $func = \&encode;
+ }
+ my $data = &{$func}( $line->[ $i ] );
+ $data = "" unless( defined( $data ) );
+ print $header.$data.'</td>';
+ }
+ print "</tr>\n";
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Html::Forms;
+use strict;
+use warnings;
+use base 'Exporter';
+use CGI;
+use HTML::Entities;
+
+our @EXPORT = qw(&genForm &getForm &genFormEx &getFormValue &genRadios);
+
+sub genFormEx( $$ ) {
+ my( $inputs, $values ) = @_;
+ foreach( @{$inputs} ) {
+ my( $kind, $label, $type, $name, $other ) = @{$_};
+ $other = '' unless( defined $other );
+ print '<tr><td>'.$label.'<td><'.$kind.( ( defined $type ) ? ' type="'.$type.'"' : '' ).' name="'.$name.'" '.$other.( defined( $values->{$name} && ( $label ne 'textarea' ) ) ? 'value="'.encode_entities( $values->{$name} ).'" ' : '' ).">\n";
+ if( $kind eq 'textarea' ) {
+ print encode_entities( $values->{$name} ) if( defined( $values->{$name} ) );
+ print "</$kind>\n";
+ }
+ }
+}
+
+sub genForm( $$ ) {
+ my( $inputs, $values ) = @_;
+ my @transformed;
+ foreach( @{$inputs} ) {
+ my @ln = @{$_};
+ unshift @ln, "input";
+ push @transformed, \@ln;
+ }
+ genFormEx( \@transformed, $values );
+}
+
+sub getFormValue( $$ ) {
+ my( $name, $default ) = @_;
+ my $result = CGI::param( $name );
+ $result = $default unless( defined( $result ) );
+ return $result;
+}
+
+sub getForm( $$ ) {
+ my( $data, $checks ) = @_;
+ my %result;
+ my @errors;
+ foreach( keys %{$data} ) {
+ my $d = CGI::param( $_ );
+ my $sub = $data->{$_};
+ my ( $err, $newval ) = &{$sub}( $d ) if( defined $sub );
+ $d = $newval if( defined $newval );
+ push @errors, $err if( defined $err );
+ $result{$_} = $d;
+ }
+ foreach( @{$checks} ) {
+ my $err = &{$_}( \%result );
+ push @errors, $err if( defined $err );
+ }
+ return ( \%result, ( @errors ) ? ( join '<p>', ( '', @errors ) ) : undef );
+}
+
+sub genRadios( $$$ ) {
+ my( $list, $name, $default ) = @_;
+ foreach( @{$list} ) {
+ my( $label, $value ) = @{$_};
+ print "<input type='radio' name='$name' value='$value'".( $value eq $default ? " checked='checked' " : "" )."> $label<br>\n";
+ }
+}
+
+1;
--- /dev/null
+package PciIds::Html::Handler;
+use strict;
+use warnings;
+use PciIds::Db;
+use PciIds::Html::Tables;
+use PciIds::Html::Util;
+use PciIds::Html::List;
+use PciIds::Html::Users;
+use PciIds::Html::Debug;
+use PciIds::Html::Changes;
+use PciIds::Html::Admin;
+use PciIds::Html::Notifications;
+use PciIds::Notifications;
+use Apache2::Const qw(:common :http);
+
+my $dbh = connectDb();
+my $tables = PciIds::Html::Tables::new( $dbh );
+
+my %handlers = (
+ 'GET' => {
+ 'list' => \&PciIds::Html::List::list,#List items
+ '' => \&PciIds::Html::List::list,
+ #Database changes
+ 'newitem' => \&PciIds::Html::Changes::newItemForm,
+ 'newcomment' => \&PciIds::Html::Changes::newCommentForm,
+ #Registering users
+ 'register' => \&PciIds::Html::Users::registerForm,
+ 'register-confirm' => \&PciIds::Html::Users::confirmForm,
+ #Logins
+ 'login' => \&PciIds::Html::Users::loginForm,
+ 'logout' => \&PciIds::Html::Users::logout,
+ 'respass' => \&PciIds::Html::Users::resetPasswdForm,
+ 'respass-confirm' => \&PciIds::Html::Users::resetPasswdConfirmForm,
+ #User profile
+ 'profile' => \&PciIds::Html::Users::profileForm,
+ #Admin
+ 'admin' => \&PciIds::Html::Admin::adminForm,
+ #Some debug
+ 'test' => \&PciIds::Html::Debug::test,
+ #Notifications
+ 'notifications' => \&PciIds::Html::Notifications::notifForm
+ },
+ 'POST' => {
+ 'newitem' => \&PciIds::Html::Changes::newItemSubmit,
+ 'newcomment' => \&PciIds::Html::Changes::newCommentSubmit,
+ 'register' => \&PciIds::Html::Users::registerSubmit,
+ 'register-confirm' => \&PciIds::Html::Users::confirmSubmit,
+ 'login' => \&PciIds::Html::Users::loginSubmit,
+ 'respass' => \&PciIds::Html::Users::resetPasswdFormSubmit,
+ 'respass-confirm' => \&PciIds::Html::Users::resetPasswdConfirmFormSubmit,
+ 'profile' => \&PciIds::Html::Users::profileFormSubmit,
+ 'admin' => \&PciIds::Html::Admin::submitAdminForm,
+ 'notifications' => \&PciIds::Html::Notifications::notifFormSubmit
+ }
+);
+
+sub handler( $$ ) {
+ my( $req, $hasSSL ) = @_;
+ return DECLINED if( $req->uri() =~ /^\/(static)\// );
+ my $args = parseArgs( $req->args() );
+ my $action = $args->{'action'};
+ $action = '' unless( defined $action );
+ my $method = $handlers{$req->method()};
+ return HTTP_METHOD_NOT_ALLOWED unless( defined $method );#Can't handle this method
+ my $sub = $method->{$action};
+ return HTTP_BAD_REQUEST unless( defined $sub );#I do not know this action for given method
+ my $auth = checkLogin( $req, $tables );#Check if logged in
+ $auth->{'ssl'} = $hasSSL;
+ my $result = &{$sub}( $req, $args, $tables, $auth );#Just do the right thing
+ $tables->commit();
+ return $result;
+}
+
+1;
--- /dev/null
+package PciIds::Html::HandlerPlain;
+use strict;
+use warnings;
+use PciIds::Html::Handler;
+
+sub handler( $ ) {
+ return PciIds::Html::Handler::handler( shift, 0 );
+}
+
+1;
--- /dev/null
+package PciIds::Html::HandlerSSL;
+use strict;
+use warnings;
+use PciIds::Html::Handler;
+
+sub handler( $ ) {
+ return PciIds::Html::Handler::handler( shift, 1 );
+}
+
+1;
--- /dev/null
+package PciIds::Html::List;
+use strict;
+use warnings;
+use PciIds::Address;
+use PciIds::Html::Util;
+use Apache2::Const qw(:common :http);
+use base 'Exporter';
+
+our @EXPORT = qw(&loadItem);
+
+sub loadItem( $$ ) {
+ my( $tables, $uri ) = @_;
+ my $address = PciIds::Address::new( $uri );
+ return ( 0 ) unless( defined $address );
+ my $item = $tables->item( $address->get() );
+ return ( 0 ) unless( defined $item );
+ my( $parent, $name, $description, $maincomment ) = @{$item};
+ return ( 1, $parent, $name, $description, $address, $maincomment );
+}
+
+sub list( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ my( $ok, $parent, $name, $description, $address, $mid ) = loadItem( $tables, $req->uri() );
+ return NOT_FOUND unless( $ok );
+ my $id = $address->pretty();
+ genHtmlHead( $req, $id, undef );
+ print '<h1>'.encode( $id ).'</h1>';
+ genMenu( $address, $args, $auth );
+ print htmlDiv( 'name', '<p>'.encode( $name ) ) if( defined( $name ) );
+ print htmlDiv( 'description', '<p>'.encode( $description ) ) if( defined( $description ) );
+ print '<p><a class="navigation" href="/read/'.$address->parent()->get().'/">'.encode( $address->parent()->pretty() )."</a>" if( defined( $address->parent() ) );
+ my $diss = 0;
+ my $comment;
+ foreach $comment ( @{$tables->history( $address->get() )} ) {
+ unless( $diss ) {
+ print "<div class='discussion'>\n<h2>Discussion</h2>";
+ $diss = 1;
+ }
+ my( $id, $text, $time, $name, $description, $seen, $user ) = @{$comment};
+ my $type = $seen ? 'comment' : 'unseen-comment';
+ $type = 'main-comment' if( defined( $mid ) && ( $id == $mid ) );
+ print "<div class='$type'>\n";
+ print "<p class='itemname'>Name: ".encode( $name )."\n" if( defined( $name ) && ( $name ne '' ) );
+ print "<p class='itemdescription'>Description: ".encode( $description )."\n" if( defined( $description ) && ( $description ne '' ) );
+ if( defined( $text ) && ( $text ne '' ) ) {
+ $text = encode( $text );
+ $text =~ s/\n/<br>/g;
+ print "<p class='comment-text'>$text\n";
+ }
+ print "<p class='author'>".encode( $user )."\n" if( defined( $user ) );
+ print "<p class='time'>".encode( $time )."\n";
+ print "</div>\n";
+ }
+ print "</div>\n" if( $diss );
+ unless( $address->leaf() ) {
+ print "<h2>Subitems</h2>\n";
+ my $restricts = $address->defaultRestrictList();
+ if( scalar @{$restricts} ) {
+ print "<p>";
+ my $url = '/read/'.$address->get().buildExcept( 'restrict', $args ).'?restrict=';
+ foreach( @{$restricts} ) {
+ print "<a href='".$url.$_->[0]."'>".$_->[1]."</a> ";
+ }
+ }
+ my $url = '/read/'.$address->get().buildExcept( 'sort', $args );
+ my $sort = ( $args->{'sort'} or 'id' );
+ my( $sort_id, $sort_name ) = ( ( $sort eq 'id' ? 'rid' : 'id' ), ( $sort eq 'name' ? 'rname' : 'name' ) );
+ genTableHead( 'subnodes', [ '<a href="'.$url.'?sort='.$sort_id.'">Id</a>', '<a href="'.$url.'?sort='.$sort_name.'">Name</a>', 'Description' ] );
+ $args->{'restrict'} = $address->defaultRestrict() unless( defined( $args->{'restrict'} ) );
+ $tables->nodes( $address->get(), $args );
+ genTableTail();
+ }
+ genHtmlTail();
+ return OK;
+}
+
+1;
--- /dev/null
+package PciIds::Html::Notifications;
+use strict;
+use warnings;
+use PciIds::Html::Util;
+use PciIds::Html::Forms;
+use PciIds::Html::Users;
+use PciIds::Address;
+use Apache2::Const qw(:common :http);
+
+sub genNotifForm( $$$$$$ ) {
+ my( $req, $args, $tables, $auth, $error, $data ) = @_;
+ my $addr = PciIds::Address::new( $req->uri() );
+ genHtmlHead( $req, $addr->pretty().' - notifications', undef );
+ print "<h1>".$addr->pretty()." - notifications</h1>\n";
+ print "<div class='error'>$error</div>\n" if( defined $error );
+ my $uri = $addr->get();
+ my $notifs = $tables->notificationsUser( $auth->{'authid'} );
+ my $started;
+ foreach( @{$notifs} ) {
+ my( $location, $recursive ) = @{$_};
+ if( ( substr( $uri, 0, length $location ) eq $location ) && $recursive && ( length $location < length $uri ) ) {
+ unless( $started ) {
+ print "<div class='navigation'><h2>Item already covered by</h2><ul>\n";
+ $started = 1;
+ }
+ print "<li><a href='/$location".buildArgs( $args )."'>".PciIds::Address::new( $location )->pretty()."</a>\n";
+ }
+ }
+ print "</ul></div>\n" if( $started );
+ print "<form name='notifications' id='notifications' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=notifications'>\n";
+ print "<p><input type='checkbox' value='recursive' name='recursive'".( $data->{'recursive'} ? " checked='checked'" : "" )."> Recursive\n";
+ print "<h3>Notification level</h3>\n";
+ print "<p>\n";
+ genRadios( [ [ 'None', '3' ], [ 'Main comment & new subitem', '2' ], [ 'Description', '1' ], [ 'Comment', '0' ] ], 'notification', ( defined $data->{'notification'} ) ? $data->{'notification'} : '3' );
+ print "<h3>Notification way</h3>\n";
+ print "<p>\n";
+ genRadios( [ [ 'Email', '0' ], [ 'Xmpp', '1' ], [ 'Both', '2' ] ], 'way', ( defined $data->{'way'} ) ? $data->{'way'} : '0' );
+ print "<p><input type='submit' value='Submit' name='submit'>\n";
+ print "</form>\n";
+ if( @{$notifs} ) {
+ print "<div class='navigation'><h3>All notifications</h3><ul>\n";
+ foreach( @{$notifs} ) {
+ my( $location ) = @{$_};
+ print "<li><a href='/$location".buildArgs( $args )."'>".PciIds::Address::new( $location )->pretty()."</a>\n";
+ }
+ print "</ul></div>\n";
+ }
+ print "<a class='navigation' href='".setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list'>Back to browsing</a>\n";
+ genHtmlTail();
+ return OK;
+}
+
+sub notifForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ if( defined $auth->{'authid'} ) {
+ return genNotifForm( $req, $args, $tables, $auth, undef, $tables->getNotifData( $auth->{'authid'}, PciIds::Address::new( $req->uri() )->get() ) );
+ } else {
+ return notLoggedComplaint( $req, $args, $auth );
+ }
+}
+
+sub range( $$$ ) {
+ my( $value, $name, $max ) = @_;
+ return ( "Invalid number in $name", 0 ) if $value !~ /\d+/;
+ return ( "Invalid range in $name", 0 ) if ( $value < 0 ) || ( $value > $max );
+ return undef;
+}
+
+sub notifFormSubmit( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
+ my( $data, $error ) = getForm( {
+ 'notification' => sub { return range( shift, "notification", 3 ); },
+ 'way' => sub { return range( shift, "way", 2 ); },
+ 'recursive' => sub {
+ my $value = shift;
+ return ( undef, 1 ) if ( defined $value ) && ( $value eq 'recursive' );
+ return ( undef, 0 ) if ( !defined $value ) || ( $value eq '' );
+ return ( 'Invalid value in recursive', 0 );
+ }
+ }, [] );
+ return genNotifForm( $req, $args, $tables, $auth, $error, $data ) if defined $error;
+ $tables->submitNotification( $auth->{'authid'}, PciIds::Address::new( $req->uri() )->get(), $data );
+ return HTTPRedirect( $req, setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list" );
+}
+
+1;
--- /dev/null
+package PciIds::Html::Tables;
+use strict;
+use warnings;
+use base 'PciIds::DBQ';
+use PciIds::Html::Format;
+use PciIds::Address;
+
+sub new( $ ) {
+ my( $dbh ) = @_;
+ return bless PciIds::DBQ::new( $dbh );
+}
+
+sub formatLink( $ ) {
+ my $address = PciIds::Address::new( shift );
+ return '<a href="/read/'.$address->get().'">'.$address->tail().'</a>';
+}
+
+sub nodes( $$$ ) {
+ my( $self, $parent, $args ) = @_;
+ my $restrict = $args->{'restrict'};
+ $restrict = '' unless( defined $restrict );
+ $restrict = PciIds::Address::new( $parent )->restrictRex( $restrict );#How do I know if the restrict is OK?
+ htmlFormatTable( PciIds::DBQ::nodes( $self, $parent, $args, $restrict ), 3, [], [ \&formatLink ], sub { 1; }, sub { return ' class="'.( defined( shift->[ 3 ] ) ? 'item' : 'unnamedItem' ).'"'; } );
+}
+
+1;
--- /dev/null
+package PciIds::Html::Users;
+use strict;
+use warnings;
+use PciIds::Html::Util;
+use PciIds::Html::Forms;
+use PciIds::Email;
+use PciIds::Users;
+use CGI;
+use CGI::Cookie;
+use Apache2::Const qw(:common);
+use Apache2::SubRequest;
+use APR::Table;
+
+use base 'Exporter';
+
+our @EXPORT = qw(&checkLogin ¬LoggedComplaint);
+
+sub genRegisterForm( $$$$ ) {
+ my( $req, $args, $error, $values ) = @_;
+ genHtmlHead( $req, 'Register a new user', undef );
+ print '<h1>Register a new user</h1>';
+ print '<div class="error">'.$error.'</div>' if( defined $error );
+ print '<form name="register" id="register" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=register">
+ <table>';
+ genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
+ [ '', 'submit', 'register', 'value="Register"' ] ], $values );
+ print '</table></form>';
+ genHtmlTail();
+ return OK;
+}
+
+sub registerForm( $$ ) {#Form for registering a new user
+ my( $req, $args ) = @_;
+ return genRegisterForm( $req, $args, undef, {} );
+}
+
+sub loginCheck( $$ ) {
+ my( $login, $tables ) = @_;
+ return undef if( ( not defined $login ) || ( $login eq '' ) );#empty login is ok
+ return 'Login too long' if( ( length $login ) > 50 );
+ return 'Login contains invalid characters' unless( $login =~ /^[-_a-zA-Z0-9]+$/ );
+ return 'This login already exists' if( $tables->hasLogin( $login ) );
+ return undef;
+}
+
+sub emailCheck( $$ ) {
+ my( $email, $tables ) = @_;
+ my $newmail;
+ return 'Does not look like an email address' unless ( ( $newmail ) = ( $email =~ /^([^,? "'`;]+@[^@,?\/ "'`;]+)$/ ) );#make sure the mail is not only reasonable looking, but safe to work with too
+ return 'Email too long' if length $newmail > 255;
+ return 'An account for this email address already exists' if( $tables->hasEmail( $newmail ) );
+ return ( undef, $newmail );
+}
+
+sub registerSubmit( $$$ ) {#A registration form has been submited
+ my( $req, $args, $tables ) = @_;
+ my( $data, $error ) = getForm( {
+ 'email' => sub {
+ return emailCheck( shift, $tables );
+ }
+ }, [] );
+ return genRegisterForm( $req, $args, $error, $data ) if( defined $error );
+ my $site = $req->hostname();
+ my $url = 'https://'.$req->hostname().setAddrPrefix( $req->uri(), 'mods' );
+ sendMail( $data->{'email'}, 'Confirm registration', "Someone, probably you, requested registration of this address\n".
+ "for the $site site. If it wasn't you, please ignore this email message.\n".
+ "\nOtherwise, please continue by filling in the form at this address:".
+ "\n".$url.'?action=register-confirm?email='.$data->{'email'}.'?confirm='.emailConfirm( $data->{'email'} )."\n".
+ "\nThank you\n".
+ "\n(This is an autogenerated email, do not respond to it)" );
+ genHtmlHead( $req, 'Registration email sent', undef );
+ print '<h1>Register email sent</h1>
+ <p>
+ An email containing further information has been sent to you.
+ Please follow these instruction to finish the registration process.';
+ genHtmlTail();
+ return OK;
+}
+
+sub genConfirmForm( $$$$ ) {
+ my( $req, $args, $error, $values ) = @_;
+ genHtmlHead( $req, 'Confirm registration', undef );
+ print '<h1>Confirm registration</h1>';
+ print '<div class="error">'.$error.'</div>' if( defined $error );
+ print '<p>Email address: '.encode( $values->{'email'} );
+ print '<form name="register-confirm" id="register-confirm" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=register-confirm">';
+ print '<div class="hidden"><p><input type="hidden" value="'.encode( $values->{'email'} ).'" name="email"><input type="hidden" value="'.encode( $values->{'confirm'} ).'" name="confirm"></div>';
+ print '<table>';
+ genForm( [ [ 'Login (Optional):', 'text', 'login', 'maxlength="50"' ],
+ [ 'Password:', 'password', 'password' ],
+ [ 'Confirm password:', 'password', 'confirm_password' ],
+ [ '', 'submit', 'register', 'value=Register' ] ], $values );
+ print '</table></form>';
+ genHtmlTail();
+ return OK;
+}
+
+sub usedAddress( $ ) {
+ my( $req ) = @_;
+ genHtmlHead( $req, 'Used address', undef );
+ print '<h1>Used address</h1>
+ <div class="error">
+ <p>
+ An account for this address is already registered.
+ Please, start again with <a href="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=register">requesting a registration email</a> or <a href="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=login">log in</a>.
+ </div>';
+ genHtmlTail();
+ return 0;
+}
+
+sub checkRegHash( $$$$ ) {
+ my( $req, $tables, $email, $hash ) = @_;
+ if( ! checkConfirmHash( $email, $hash ) ) {
+ genHtmlHead( $req, 'Invalid registration request', undef );
+ print '<h1>Invalid registration request</h1>
+ <div class="error">
+ <p>
+ This registration request is invalid.
+ Are you sure you got it from the registration email?
+ </div>';
+ genHtmlTail();
+ return 0;
+ } elsif( $tables->hasEmail( $email ) ) {
+ return usedAddress( $req );
+ } else {
+ return 1;
+ }
+}
+
+sub confirmForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
+ if( ! checkRegHash( $req, $tables, $args->{'email'}, $args->{'confirm'} ) ) {
+ return OK;
+ } else {
+ return genConfirmForm( $req, $args, undef, $args );
+ }
+}
+
+sub passLenCheck( $ ) {
+ my( $pass ) = @_;
+ return ( ( length $pass ) >= 4 ) ? undef : 'Password must have at least 4 characters';
+}
+
+sub passSameCheck( $ ) {
+ my( $data ) = @_;
+ return ( ( ( defined $data->{'password'} ) != ( defined $data->{'confirm_password'} ) ) || ( ( defined $data->{'password'} ) && ( $data->{'password'} ne $data->{'confirm_password'} ) ) ) ? 'Passwords do not match' : undef;
+}
+
+sub confirmSubmit( $$$ ) {
+ my( $req, $args, $tables ) = @_;
+ my( $data, $error ) = getForm( {
+ 'email' => sub {
+ return emailCheck( shift, $tables );
+ },
+ 'confirm' => undef,
+ 'login' => sub {
+ return loginCheck( shift, $tables );
+ },
+ 'password' => \&passLenCheck,
+ 'confirm_password' => undef }, [ \&passSameCheck ] );
+ return OK if( ! checkRegHash( $req, $tables, $data->{'email'}, $data->{'confirm'} ) );#Not much info, but this is an attack anyway
+ return genConfirmForm( $req, $args, $error, $data ) if( defined $error );
+ unless( addUser( $tables, $data->{'login'}, $data->{'email'}, $data->{'password'} ) ) {
+ usedAddress( $req );
+ return OK;
+ }
+ genHtmlHead( $req, 'Registered', undef );
+ print '<h1>Registered</h1>
+ <p>
+ You are now registered.
+ You can continue by <a href="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=login">logging in</a> or continue <a href="http://'.$req->hostname().setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args ).'?action=list">anonymously</a>.';
+ genHtmlTail();
+ return OK;
+}
+
+sub genLoginForm( $$$$ ) {
+ my( $req, $args, $error, $values ) = @_;
+ $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'cookie-test', -value => 1 ) );
+ genHtmlHead( $req, 'Login', undef );
+ print '<h1>Login</h1>';
+ my $addr = PciIds::Address::new( $req->uri() );
+ genCustomMenu( $addr, $args, [ [ 'Register', 'register' ], [ 'Reset password', 'respass' ] ] );
+ print '<div class="error"><p>'.$error.'</div>' if( defined $error );
+ print '<form name="login" id="login" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=login"><table>';
+ genForm( [ [ 'Login name or email:', 'text', 'login', 'maxlength="255"' ],
+ [ 'Password:', 'password', 'password' ],
+ [ '', 'submit', 'login', 'value="Login"' ] ], $values );
+ print '</table></form>';
+ genHtmlTail();
+ return OK;
+}
+
+sub loginForm( $$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless( $auth->{'ssl'} );
+ return genLoginForm( $req, $args, undef, {} );
+}
+
+sub loginSubmit( $$$ ) {
+ my( $req, $args, $tables ) = @_;
+ my( $data, $error ) = getForm( {
+ 'login' => undef,
+ 'password' => undef
+ }, [] );
+ my $logged = 0;
+ my $cookies = fetch CGI::Cookie;
+ unless( $cookies->{'cookie-test'} ) {
+ return genLoginForm( $req, $args, 'You need to enable cookies', $data );
+ }
+ my( $id, $passwd, $email, $last ) = $tables->getLogInfo( $data->{'login'} );
+ if( defined $passwd && defined $data->{'password'} ) {
+ my $salted = saltedPasswd( $email, $data->{'password'} );
+ $logged = $salted eq $passwd;
+ }
+ if( $logged ) {
+ $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => genAuthToken( $tables, $id, $req, undef ) ) );
+ $args->{'action'} = ( defined $args->{'redirectaction'} ) ? $args->{'redirectaction'} : 'list';
+ my $prefix = ( !defined( $args->{'action'} ) or ( $args->{'action'} eq '' ) or ( $args->{'action'} eq 'list' ) ) ? 'read' : 'mods';
+ my $url = "http://".$req->hostname().setAddrPrefix( $req->uri(), $prefix ).buildExcept( 'redirectaction', $args );
+ genHtmlHead( $req, 'Logged in', undef );
+ print '<h1>Logged in</h1>';
+ print '<div class="lastlog"><p>'.encode( $last ).'</div>' if( defined( $last ) );
+ print "<p><a href='$url'>Continue here</a>";
+ genHtmlTail();
+ return OK;
+ } else {
+ return genLoginForm( $req, $args, 'Invalid login credetials', $data );
+ }
+}
+
+sub logout( $$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => '0' ) );
+ return PciIds::Html::List::list( $req, $args, $tables, {} );
+}
+
+sub checkLogin( $$ ) {
+ my( $req, $tables ) = @_;
+ my $cookies = fetch CGI::Cookie;
+ my( $authed, $id, $regen, $rights, $error ) = checkAuthToken( $tables, $req, defined( $cookies->{'auth'} ) ? $cookies->{'auth'}->value : undef );
+ if( $regen ) {
+ $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => genAuthToken( $tables, $id, $req, $rights ) ) );
+ }
+ my $hterror = $authed ? '' : '<div class="error"><p>'.$error.'</div>';
+ return { 'authid' => $authed ? $id : undef, 'accrights' => $rights, 'logerror' => $hterror };
+}
+
+sub notLoggedComplaint( $$$ ) {
+ my( $req, $args, $auth ) = @_;
+ return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
+ $args->{'redirectaction'} = $args->{'action'};
+ return genLoginForm( $req, $args, 'This action requires you to be logged in', undef );
+}
+
+sub genResetPasswdForm( $$$$ ) {
+ my( $req, $args, $error, $values ) = @_;
+ genHtmlHead( $req, 'Reset password', undef );
+ print "<h1>Reset password</h1>\n";
+ print "<p>If you forgot your password (or didn't create one yet), you can reset it to a new value here.\n";
+ print "Provide your email address here and further instructions will be sent to you.\n";
+ print '<div class="error">'.$error.'</div>' if( defined $error );
+ print '<form name="respass" id="respass" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=respass">
+ <table>';
+ genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
+ [ '', 'submit', 'respass', 'value="Send"' ] ], $values );
+ print '</table></form>';
+ genHtmlTail();
+ return OK;
+}
+
+sub resetPasswdForm( $$$$ ) {
+ my( $req, $args ) = @_;
+ return genResetPasswdForm( $req, $args, undef, {} );
+}
+
+sub resetPasswdFormSubmit( $$$ ) {
+ my( $req, $args, $tables ) = @_;
+ my( $data, $error ) = getForm( {
+ 'email' => undef
+ }, [] );
+ my( $id, $login, $passwd ) = $tables->resetInfo( $data->{'email'} );
+ if( defined( $id ) ) {
+ $login = '' unless( defined( $login ) );
+ my $site = $req->hostname();
+ my $url = 'https://'.$req->hostname().setAddrPrefix( $req->uri(), 'mods' );
+ my $hash = genResetHash( $id, $data->{'email'}, $login, $passwd );
+ sendMail( $data->{'email'}, 'Reset password',
+ "A request to reset password for the $site site was received for this address\n".
+ "If you really wish to get a new password, visit this link:\n\n".
+ $url.'?action=respass-confirm?email='.$data->{'email'}.'?confirm='.$hash."\n".
+ "\n\nThank you\n".
+ "\n(This is an autogenerated email, do not respond to it)" );
+ genHtmlHead( $req, 'Reset password', undef );
+ print "<h1>Reset password</h1>\n";
+ print "<p>An email with information was sent to your address.\n";
+ genHtmlTail();
+ return OK;
+ } else {
+ $error = '<p>This email address is not registered. Check it for typos or <a href="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=register">register</a> it.';
+ }
+ return genResetPasswdForm( $req, $args, $error, $data ) if( defined( $error ) );
+}
+
+sub genResetPasswdConfigForm( $$$$$$ ) {
+ my( $req, $args, $error, $values, $email, $hash ) = @_;
+ genHtmlHead( $req, 'Reset password', undef );
+ print "<h1>Reset password</h1>\n";
+ print '<div class="error">'.$error.'</div>' if( defined $error );
+ print "<p>You can enter new password here:\n";
+ print '<form name="respass-confirm" id="respass-confirm" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=respass-confirm">
+ <table>';
+ genForm( [ [ 'Password:', 'password', 'password' ],
+ [ 'Confirm password:', 'password', 'confirm_password' ],
+ [ '', 'submit', 'respass', 'value="Send"' ] ], $values );
+ print "</table>";
+ print "<input type='hidden' name='email' value='".encode( $email )."'><input type='hidden' name='hash' value='".encode( $hash )."'>\n";
+ print "</form>\n";
+ genHtmlTail();
+ return OK;
+}
+
+sub resetPasswdConfirmForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ my( $email, $hash ) = ( $args->{'email'}, $args->{'confirm'} );
+ my( $id, $login, $passwd ) = $tables->resetInfo( $email );
+ my $myHash;
+ return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
+ $myHash = genResetHash( $id, $email, $login, $passwd ) if( defined( $id ) );
+ if( defined( $myHash ) && ( $myHash eq $hash ) ) {#Ok, it is his mail and he asked
+ return genResetPasswdConfigForm( $req, $args, undef, {}, $email, $hash );
+ } else {
+ genHtmlHead( $req, 'Reset password', undef );
+ print "<h1>Reset password</h1>\n";
+ print "<p>Provided link is not valid. Did you use it already?\n";
+ print "<p>You can get a <a href='".$req->uri()."?action=respass'>new one</a>.\n";
+ genHtmlTail();
+ return OK;
+ }
+}
+
+sub resetPasswdConfirmFormSubmit( $$$ ) {
+ my( $req, $args, $tables ) = @_;
+ my( $data, $error ) = getForm( {
+ 'password' => \&passLenCheck,
+ 'confirm_password' => undef,
+ 'email' => undef,
+ 'hash' => undef
+ }, [ \&passSameCheck ] );
+ my( $email, $hash ) = ( $data->{'email'}, $args->{'confirm'} );
+ if( defined( $error ) ) {
+ return genResetPasswdConfigForm( $req, $args, $error, $data, $email, $hash );
+ } else {
+ my( $id, $login, $passwd ) = $tables->resetInfo( $email );
+ my $myHash;
+ $myHash = genResetHash( $id, $email, $login, $passwd ) if( defined( $id ) );
+ if( defined( $myHash ) && ( $myHash eq $hash ) ) {
+ changePasswd( $tables, $id, $data->{'password'}, $email );
+ genHtmlHead( $req, 'Reset password', undef );
+ print "<h1>Reset password</h1>\n";
+ print "<p>Your password was successfuly changed. You can <a href='".$req->uri()."?action=login'>log in</a>.\n";
+ genHtmlTail();
+ return OK;
+ } else {
+ return genResetPasswdConfigForm( $req, $args, $error, $data, $email, $hash );
+ }
+ }
+}
+
+sub genProfileForm( $$$$$ ) {
+ my( $req, $args, $error, $data, $info ) = @_;
+ genHtmlHead( $req, 'User profile', undef );
+ delete $data->{'current_password'};
+ delete $data->{'confirm_password'};
+ delete $data->{'password'};
+ print "<h1>User profile</h1>\n";
+ print '<div class="error"><p>'.$error.'</div>' if defined $error;
+ print "<div class='info'><p>$info</div>\n" if defined $info;
+ print '<form name="profile" id="profile" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=profile"><table>';
+ genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
+ [ 'Login:', 'text', 'login', 'maxlength="50"' ],
+ [ 'Xmpp:', 'text', 'xmpp', 'maxlength="255"' ],
+ [ 'New password:', 'password', 'password' ],
+ [ 'Confirm password:', 'password', 'confirm_password' ],
+ [ 'Current password:', 'password', 'current_password' ],
+ [ 'Email batch time (min):', 'text', 'email_time', 'maxlength="10"' ],
+ [ 'Xmpp batch time (min):', 'text', 'xmpp_time', 'maxlength="10"' ],
+ [ '', 'submit', 'profile', 'value="Submit"' ] ], $data );
+ print '</table></form>';
+ print "<p><a class='navigation' href='http://".$req->hostname().setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list'>Back to browsing</a>\n";
+ genHtmlTail();
+ return OK;
+}
+
+sub profileForm( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
+ return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
+ return genProfileForm( $req, $args, undef, $tables->profileData( $auth->{'authid'} ), undef );
+}
+
+sub checkNum( $$ ) {
+ my( $value, $name ) = @_;
+ return ( "$name has invalid number format", '0' ) unless ( $value =~ /\d+/ );
+ return undef;
+}
+
+sub profileFormSubmit( $$$$ ) {
+ my( $req, $args, $tables, $auth ) = @_;
+ return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
+ my $oldData = $tables->profileData( $auth->{'authid'} );
+ my( $data, $error ) = getForm( {
+ 'email' => sub {
+ my $email = shift;
+ return undef if ( defined $email ) && ( $email eq $oldData->{'email'} );
+ return emailCheck( $email, $tables );
+ },
+ 'login' => sub {
+ my $login = shift;
+ $login = undef if ( defined $login ) && ( $login eq '' );
+ return undef if ( defined $login ) && ( defined $oldData->{'login'} ) && ( $oldData->{'login'} eq $login );
+ return ( undef, $login ) if ( !defined $login ) && ( !defined $oldData->{'login'} );
+ return loginCheck( $login, $tables );
+ },
+ 'xmpp' => sub {
+ my $xmpp = shift;
+ return ( undef, undef ) if ( !defined $xmpp ) || ( $xmpp eq '' );
+ return "Xmpp address limit is 255" if length $xmpp > 255;
+ return "Invalid Xmpp address" unless $xmpp =~ /^([^'"\@<>\/]+\@)?[^\@'"<>\/]+(\/.*)?/;
+ return undef;
+ },
+ 'password' => sub {
+ my $passwd = shift;
+ $passwd = undef if ( defined $passwd ) && ( $passwd eq '' );
+ return ( undef, undef ) unless defined $passwd;
+ return passLenCheck( $passwd );
+ },
+ 'confirm_password' => undef,
+ 'current_password' => undef,
+ 'email_time' => sub {
+ return checkNum( shift, "Email batch time" );
+ },
+ 'xmpp_time' => sub {
+ return checkNum( shift, "Xmpp batch time" );
+ }
+ }, [ sub {
+ my $data = shift;
+ return undef unless defined $data->{'password'};
+ return passSameCheck( $data );
+ }, sub {
+ my $data = shift;
+ my $change = 0;
+ $change = 1 if $data->{'email'} ne $oldData->{'email'};
+ $change = 1 if ( ( ( defined $data->{'login'} ) != ( defined $oldData->{'login'} ) ) || ( ( defined $data->{'login'} ) && ( defined $oldData->{'login'} ) && ( $data->{'login'} ne $oldData->{'login'} ) ) );
+ $change = 1 if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
+ return undef unless $change;
+ my $logged = 0;
+ my( $id, $passwd, $email, $last ) = $tables->getLogInfo( $oldData->{'email'} );
+ if( defined $passwd && defined $data->{'current_password'} ) {
+ my $salted = saltedPasswd( $email, $data->{'current_password'} );
+ $logged = ( $salted eq $passwd ) && ( $id == $auth->{'authid'} );
+ }
+ return "You need to provide correct current password to change email, login or password" unless $logged;
+ return undef;
+ } ] );
+ return genProfileForm( $req, $args, $error, $data, undef ) if defined $error;
+ pushProfile( $tables, $auth->{'authid'}, $oldData, $data );
+ return genProfileForm( $req, $args, undef, $data, "Profile updated." );
+}
+
+1;
--- /dev/null
+package PciIds::Html::Util;
+use strict;
+use warnings;
+use HTML::Entities;
+use base 'Exporter';
+use PciIds::Users;
+use Apache2::Const qw(:common :http);
+use APR::Table;
+
+our @EXPORT = qw(&genHtmlHead &htmlDiv &genHtmlTail &genTableHead &genTableTail &parseArgs &buildExcept &buildArgs &genMenu &genCustomMenu &encode &setAddrPrefix &HTTPRedirect);
+
+sub encode( $ ) {
+ return encode_entities( shift, "\"'&<>" );
+}
+
+sub genHtmlHead( $$$ ) {
+ my( $req, $caption, $metas ) = @_;
+ $req->content_type( 'text/html; charset=utf-8' );
+ $req->headers_out->add( 'Cache-control' => 'no-cache' );
+ print '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">'."\n";
+ print '<html lang="en"><head><title>'.encode( $caption )."</title>\n";
+ print "<link rel='stylesheet' type='text/css' media='screen' href='/static/screen.css'>\n";
+ print "<link rel='stylesheet' type='text/css' media='print' href='/static/print.css'>\n";
+ print $metas if( defined( $metas ) );
+ print "</head><body>\n";
+}
+
+sub genHtmlTail() {
+ print '</body></html>';
+}
+
+sub htmlDiv( $$ ) {
+ my( $class, $text ) = @_;
+ return '<div class="'.$class.'">'.$text.'</div>';
+}
+
+sub item( $$$ ) {
+ my( $url, $label, $action ) = @_;
+ print " <li><a href='".$url.$action."'>$label</a>\n";
+}
+
+sub genCustomMenu( $$$ ) {
+ my( $address, $args, $list ) = @_;
+ my $url = '/'.$address->get().buildExcept( 'action', $args ).'?action=';
+ print "<div class='menu'>\n<ul>\n";
+ foreach( @{$list} ) {
+ my( $label, $action ) = @{$_};
+ my $prefix = '/mods';
+ $prefix = '/read' if( !defined( $action ) or ( $action eq 'list' ) or ( $action eq '' ) );
+ item( $prefix.$url, $label, $action );
+ }
+ print "</ul></div>\n";
+}
+
+sub genMenu( $$$ ) {
+ my( $address, $args, $auth ) = @_;
+ my @list;
+ if( defined( $auth->{'authid'} ) ) {
+ push @list, [ 'Log out', 'logout' ];
+ } else {
+ push @list, [ 'Log in', 'login' ];
+ }
+ push @list, [ 'Add item', 'newitem' ] if( $address->canAddItem() );
+ push @list, [ 'Discuss', 'newcomment' ] if( $address->canAddComment() );
+ push @list, [ 'Administrate', 'admin' ] if( hasRight( $auth->{'accrights'}, 'validate' ) );
+ push @list, [ 'Profile', 'profile' ] if defined $auth->{'authid'};
+ push @list, [ 'Notifications', 'notifications' ] if defined $auth->{'authid'};
+ genCustomMenu( $address, $args, \@list );
+}
+
+sub genTableHead( $$ ) {
+ my( $class, $captions ) = @_;
+ print '<table class="'.$class.'"><tr>';
+ foreach( @{$captions} ) {
+ print '<th>'.$_;
+ }
+ print '</tr>';
+}
+
+sub genTableTail() {
+ print '</table>';
+}
+
+sub parseArgs( $ ) {
+ my %result;
+ foreach( split /\?/, shift ) {
+ next unless( /=/ );
+ my( $name, $value ) = /^([^=]+)=(.*)$/;
+ $result{$name} = $value;
+ }
+ return \%result;
+}
+
+sub buildArgs( $ ) {
+ my( $args ) = @_;
+ my $result = '';
+ $result .= "?$_=".$args->{$_} foreach( keys %{$args} );
+ return $result;
+}
+
+sub buildExcept( $$ ) {
+ my( $except, $args ) = @_;
+ my %backup = %{$args};
+ delete $backup{$except};
+ return buildArgs( \%backup );
+}
+
+sub setAddrPrefix( $$ ) {
+ my( $addr, $prefix ) = @_;
+ $addr =~ s/\/(mods|read|static)//;
+ return "/$prefix$addr";
+}
+
+sub HTTPRedirect( $$ ) {
+ my( $req, $link ) = @_;
+ $req->headers_out->add( 'Location' => $link );
+ return HTTP_SEE_OTHER;
+}
+
+1;
--- /dev/null
+package PciIds::Log;
+use strict;
+use warnings;
+use base 'Exporter';
+use PciIds::Config;
+
+our @EXPORT = qw(&flog &tlog &logEscape &tulog);
+
+checkConf( [ 'logfile' ] );
+
+sub flog( $ ) {
+ my( $text ) = @_;
+ open LOG, '>>'.$config{'logfile'} or die "Could not open log file\n";
+ print LOG "$text\n";
+ close LOG;
+}
+
+sub tlog( $ ) {
+ my( $text ) = @_;
+ my $time = time;
+ flog( "$time: $text" );
+}
+
+sub tulog( $$ ) {
+ my( $user, $text ) = @_;
+ tlog( "User $user: $text" );
+}
+
+sub logEscape( $ ) {
+ my( $text ) = @_;
+ return "''" unless defined $text;
+ $text =~ s/(['"\\])/\\$1/g;
+ return "'$text'";
+}
+
+1;
--- /dev/null
+package PciIds::Notifications;
+use strict;
+use warnings;
+use PciIds::Address;
+use PciIds::Config;
+use PciIds::Email;
+use PciIds::Xmpp;
+use base 'Exporter';
+
+our @EXPORT = qw(¬ify &sendNotifs &flushNotifs);
+
+sub notify( $$$$$ ) {
+ my( $tables, $location, $comment, $priority, $reason ) = @_;
+ $tables->pushNotifications( $location, $comment, $priority, $reason );
+}
+
+sub sendNotif( $$$ ) {
+ my( $address, $message, $sendFun ) = @_;
+ return unless defined $address;
+ &{$sendFun}(
+ $address,
+ "Item change notifications for $config{hostname}",
+ "$message\nThis is automatic notification message, do not respond to it.\nYou can change your notifications at http://$config{hostname}/mods/PC/?action=notifications\n" );
+}
+
+sub sendOut( $$ ) {
+ my( $notifs, $sendFun ) = @_;
+ my( $last_address, $last_user );
+ my $message = '';
+ foreach( @{$notifs} ) {
+ my( $user, $address, $reason, $text, $newname, $newdesc, $time, $author, $location, $name, $desc ) = @{$_};
+ if( ( !defined $last_user ) || ( $last_user != $user ) ) {
+ sendNotif( $last_address, $message, $sendFun );
+ $last_address = $address;
+ $last_user = $user;
+ $message = '';
+ }
+ my $note;
+ my $addr = PciIds::Address::new( $location );
+ if( $reason == 0 ) {
+ $note = "New item was created.\n Id: ".$addr->pretty()."\n Name: $newname\n";
+ $note .= " Description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
+ $note .= " Comment text: $text\n" if( defined $text && ( $text ne '' ) );
+ $note .= " Author: $author\n" if( defined $author && ( $author ne '' ) );
+ $note .= " Time: $time\n";
+ $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
+ } elsif( $reason == 1 ) {
+ $note = "New comment created.\n Item:\n";
+ $note .= " Id: ".$addr->pretty()."\n";
+ $note .= " Name: $name\n" if( defined $name && ( $name ne '' ) && ( $name ne $newname ) );
+ $note .= " Description: $desc\n" if( defined $desc && ( $desc ne '' ) && ( $desc ne $newdesc ) );
+ $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
+ $note .= " Comment:\n";
+ $note .= " Proposed name: $newname\n" if( defined $newname && ( $newname ne '' ) );
+ $note .= " Proposed description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
+ $note .= " Text: $text\n" if( defined $text && ( $text ne '' ) );
+ $note .= " Author: $author\n" if( defined $author && ( $author ne '' ) );
+ $note .= " Time: $time\n";
+ } elsif( $reason == 2 ) {
+ $note = "Item name validated.\n Id:".$addr->pretty()."\n";
+ $note .= " Name: $newname\n";
+ $note .= " Description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
+ $note .= " Comment text: $text\n" if( defined $text && ( $text ne '' ) );
+ $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
+ }
+ $message .= "\n" unless $message eq '';
+ $message .= $note;
+ }
+ sendNotif( $last_address, $message, $sendFun );
+}
+
+sub sendNotifs( $ ) {
+ my( $tables ) = @_;
+ my $time = $tables->time();
+ sendOut( $tables->mailNotifs( $time ), \&PciIds::Email::sendMail );
+ sendOut( $tables->xmppNotifs( $time ), \&PciIds::Xmpp::sendXmpp );
+ $tables->dropNotifs( $time );
+}
+
+checkConf( [ 'hostname' ] );
+
+1;
--- /dev/null
+package PciIds::Users;
+use strict;
+use warnings;
+use base 'Exporter';
+use PciIds::Db;
+use DBI;
+use PciIds::Config;
+use Digest::MD5 qw(md5_base64 md5_hex);#TODO Some better algorithm?
+use HTML::Entities;
+use Startup;
+use PciIds::Log;
+use Apache2::Connection;
+
+my( %privnames, %privnums );
+
+our @EXPORT = qw(&addUser &emailConfirm &checkConfirmHash &saltedPasswd &genAuthToken &checkAuthToken &hasRight &getRightDefs &genResetHash &changePasswd &pushProfile);
+
+sub saltedPasswd( $$ ) {
+ my( $email, $passwd ) = @_;
+ my $salt = $config{'passwdsalt'};
+ return md5_base64( "$email:$passwd:$salt" );
+}
+
+sub genResetHash( $$$$ ) {
+ my( $id, $email, $login, $passwd ) = @_;
+ my $salt = $config{'regmailsalt'};
+ return md5_hex( "$id:$email:$login:$passwd:$salt" );
+}
+
+sub emailConfirm( $ ) {
+ my( $email ) = @_;
+ my $salt = $config{'regmailsalt'};
+ return md5_hex( $email.$salt );
+}
+
+sub checkConfirmHash( $$ ) {
+ my( $email, $hash ) = @_;
+ return 0 unless( ( defined $email ) && ( defined $hash ) );
+ my( $expected ) = emailConfirm( $email );
+ return ( $expected eq $hash );
+}
+
+sub addUser( $$$$ ) {
+ my( $tables, $name, $email, $passwd ) = @_;
+ my $salted = saltedPasswd( $email, $passwd );
+ tlog( "Creating user $email" . ( ( defined $name ) ? " - $name" : '' ) );
+ my $id = $tables->addUser( $name, $email, $salted );
+ tlog( "User ($email) id: $id" );
+ return $id;
+}
+
+sub changePasswd( $$$$ ) {
+ my( $tables, $id, $passwd, $email ) = @_;
+ my $salted = saltedPasswd( $email, $passwd );
+ $tables->changePasswd( $id, $salted );
+}
+
+sub genAuthToken( $$$$ ) {
+ my( $tables, $id, $req, $rights ) = @_;
+ unless( defined $rights ) {#Just logged in
+ my $from = $req->connection()->remote_ip();
+ $tables->setLastLog( $id, $from );
+ $rights = $tables->rights( $id );
+ }
+ my $haveRights = scalar @{$rights};
+ my $time = time;
+ my $ip = $req->connection()->remote_ip();
+ return "$id:$haveRights:$time:".md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
+}
+
+sub checkAuthToken( $$$ ) {
+ my( $tables, $req, $token ) = @_;
+ my( $id, $haveRights, $time, $hex ) = defined( $token ) ? split( /:/, $token ) : ();
+ return ( 0, 0, 0, [], "Not logged in" ) unless( defined $hex );
+ my $ip = $req->connection()->remote_ip();
+ my $expected = md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
+ my $actTime = time;
+ my $tokOk = ( $expected eq $hex );
+ my $authed = ( $tokOk && ( $time + $config{'authtime'} > $actTime ) );
+ my $regen = $authed && ( $time + $config{'regenauthtime'} < $actTime );
+ my $rights = [];
+ if( $haveRights ) {
+ foreach( @{$tables->rights( $id )} ) {
+ my %r;
+ ( $r{'id'} ) = @{$_};
+ $r{'name'} = $privnames{$r{'id'}};
+ push @{$rights}, \%r;
+ }
+ }
+ return ( $authed, $id, $regen, $rights, $authed ? undef : ( $tokOk ? "Login timed out" : "Not logged in x" ) );
+}
+
+sub hasRight( $$ ) {
+ my( $rights, $name ) = @_;
+ foreach( @{$rights} ) {
+ return 1 if( $_->{'name'} eq $name );
+ }
+ return 0;
+}
+
+sub getRightDefs() {
+ return ( \%privnums, \%privnames );
+}
+
+sub pushProfile( $$$$ ) {
+ my( $tables, $id, $oldData, $data ) = @_;
+ my( $email, $passwd ) = ( $data->{'email'}, $data->{'current_password'} );
+ if( ( defined $passwd ) && ( $passwd ne '' ) ) {
+ my $salted = saltedPasswd( $email, $passwd );
+ $tables->setEmail( $id, $email, $salted );
+ }
+ $data->{'login'} = undef if ( defined $data->{'login'} ) && ( $data->{'login'} eq '' );
+ $data->{'xmpp'} = undef if ( defined $data->{'xmpp'} ) && ( $data->{'xmpp'} eq '' );
+ $tables->pushProfile( $id, $data->{'login'}, $data->{'xmpp'}, $data->{'email_time'}, $data->{'xmpp_time'} );
+ changePasswd( $tables, $id, $data->{'password'}, $email ) if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
+}
+
+checkConf( [ 'passwdsalt', 'regmailsalt', 'authsalt' ] );
+defConf( { 'authtime' => 2100, 'regenauthtime' => 300 } );
+
+open PRIVS, $directory."/rights" or die "Could not open privilege definitions\n";
+foreach( <PRIVS> ) {
+ my( $num, $name ) = /^(\d+)\s+(.*)$/ or die "Invalid syntax in privileges\n";
+ $privnames{$num} = $name;
+ $privnums{$name} = $num;
+}
+close PRIVS;
+
+1;
--- /dev/null
+package PciIds::Xmpp;
+use strict;
+use warnings;
+use PciIds::Config;
+use base 'Exporter';
+
+our @EXPORT = qw(&sendXmpp &flushXmpp);
+
+my @pending;
+
+sub sendXmpp( $$$ ) {
+ my( $to, $subject, $body ) = @_;
+ push @pending, [ $to, $subject, $body ];
+}
+
+sub flushXmpp() {
+ return unless @pending;
+ open JELNET, "|$config{xmpp_pipe} > /dev/null" or die "Could not start XMPP sender\n";
+ foreach( @pending ) {
+ my( $to, $subject, $body ) = @{$_};
+ $subject =~ s/&/&/g;
+ $subject =~ s/'/'/g;
+ $subject =~ s/"/"/g;
+ $body =~ s/&/&/g;
+ $body =~ s/</</g;
+ $body =~ s/>/>/g;
+ print JELNET "<message to='$to'><subject>$subject</subject><body>$body</body></message>";
+ }
+ close JELNET;
+}
+
+checkConf( [ "xmpp_pipe" ] );
+
+1;
--- /dev/null
+package Startup;
+use strict;
+use warnings;
+use base 'Exporter';
+
+#Where are data?
+our $directory = '/home/vorner/skola/cvika/internet/impl';
+our @EXPORT=qw($directory);
+
+#Where are the modules?
+use lib ( '/home/vorner/skola/cvika/internet/impl' );
+
+1;
--- /dev/null
+db = pciids
+dbuser = pciids
+dbpasswd = 1234
+passwdsalt = 1234
+regmailsalt = 1234
+authsalt = 1234
+from_addr = vorner+pciids@ucw.cz
+sendmail = /home/vorner/bin/sendmail-apache
+logfile = /home/vorner/skola/cvika/internet/impl/pciids.log
+hostname = localhost
+xmpp_pipe = /home/vorner/bin/xmpp_pipe
+++ /dev/null
-The database consists of these tables:
-
-Table of users
-==============
-Each line represents one user, be it the usual one without any
-access rights or a privileged one. There there is information about
-every user:
-• Internal ID
-• Email address
-• XMPP address
-• Login name
-• Password hash
-• Info about last login (for safety - show it on login) [can be empty]
-• Time the system should gather email notifications before sending a
-message
-• Time the system should gather XMPP notifications before sending a
-message
-• Time of the next email message [can be empty when nothing pending]
-• Time of the next XMPP message [can be empty when nothing pending]
-
-Access rights table
-===================
-Contains all access rights above the normal. It does not need any data
-with the normal users (which will be the most of them) and it is
-possible to add new rights without restructuring the database.
-Every line will contain:
-• Internal users ID
-• ID of the right (what this line allows to the user)
-• Location (for rights applied locally) [can be empty, if it makes
-no sense with the right]
-
-Table of locations
-==================
-The locations are saved in a tree. ID of the location is created by
-appending the local IDs of the nodes on the path together (children of
-the root first), separated by '/'. Each node must know, how long are
-the local IDs of its children.
-
-(Note that the local IDs can contain '/', since it can be recognized
-by its length.)
-
-The first part is 2-letter specifier of information type. The first
-version has these:
-PC: PCI ID
-PD: PCI Device Class
-
-If there is some location ending by additional '/', it means the whole
-subtree. If not, then it means the node only.
-
-For every node, this information is stored:
-• ID of the location (must be node only - without the additional '/')
-• ID of referenced location (for symlinks) [can be empty]
-• ID of the main article (see below) [can be empty]
-• Name [Can be empty, should match the main article]
-• Comment [Can be empty, should match the main article]
-
-Table of history
-================
-Contains articles in the discussion.
-
-• ID of the article
-• ID of location, where it belongs
-• Text
-• Modification of the node name [can be empty, in that case can not be
-the main article]
-• Modification of the node comment [can be empty]
-
-Table of notifications
-======================
-These are hooks for notifications.
-• ID of the user
-• ID of the location to which the notification should be sent.
-• Notification type (New article, name or comment change, change of
-the main article - everything contains all less common).
-• Way of notification (Email, XMPP, Both)
-
-Table of pending notifications
-==============================
-This is where all yet unsent notifications wait. They consist of these
-fields:
-• ID of the user
-• ID of the article
-• Way of notification (if both, it gets split into two notifications)
+++ /dev/null
-package PciIds::Address;
-use strict;
-use warnings;
-use PciIds::Address::Pci;
-use PciIds::Address::PciClass;
-
-sub new( $ ) {
- my( $address ) = @_;
- $address =~ s/\/(mods|read|static)//;#Eat the prefix
- $address =~ s/\/$//;
- $address =~ s/^\///;
- if( $address =~ /^PC/ ) {
- return PciIds::Address::Pci::new( $address );
- } elsif( $address =~ /^PD/ ) {
- return PciIds::Address::PciClass::new( $address );
- } else {
- return undef;
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Address::Base;
-use strict;
-use warnings;
-use PciIds::Address;
-
-sub new( $ ) {
- return bless {
- 'value' => shift
- }
-}
-
-sub get( $ ) {
- return shift->{'value'};
-}
-
-sub parent( $ ) {
- my( $new ) = ( shift->get() );
- $new =~ s/[^\/]+\/?$//;
- return PciIds::Address::new( $new );
-}
-
-sub tail( $ ) {
- my( $new ) = ( shift->get() );
- $new =~ s/.*\/(.)/$1/;
- return $new;
-}
-
-sub canAddComment( $ ) {
- return 1; #By default, comments can be added anywhere
-}
-
-sub canAddItem( $ ) { return !shift->leaf(); }
-
-sub defaultRestrict( $ ) { return "" };
-
-sub defaultRestrictList( $ ) { return [] };
-
-1;
+++ /dev/null
-package PciIds::Address::Pci;
-use strict;
-use warnings;
-use PciIds::Address::Toplevel;
-use base 'PciIds::Address::Base';
-
-sub new( $ ) {
- my( $address ) = @_;
- return PciIds::Address::Toplevel::new( $address ) if( $address =~ /^PC\/?$/ );
- return bless PciIds::Address::Base::new( $address );
-}
-
-sub pretty( $ ) {
- my $self = shift;
- $_ = $self->get();
- s/^PC\/?//;
- s/\//:/g;
- s/([0-9a-f]{4,4})([0-9a-f]{4,4})/$1 $2/g;
- my $prefix = '';
- if( /:.*:/ ) {
- $prefix = 'Subsystem';
- } elsif( /:/ ) {
- $prefix = 'Device';
- } else {
- $prefix = 'Vendor';
- }
- return $prefix.' '. $_;
-}
-
-sub tail( $ ) {
- my( $new ) = ( shift->get() );
- $new =~ s/.*\/(.)/$1/;
- $new =~ s/([0-9a-f]{4,4})([0-9a-f]{4,4})/$1 $2/g;
- return $new;
-}
-
-sub restrictRex( $$ ) {
- my( $self, $restrict ) = @_;
- my( $result ) = ( $restrict =~ /^([a-f0-9]{1,4})/ );#TODO every time?
- return $result;
-}
-
-sub leaf( $ ) {
- return ( shift->get() =~ /\/.*\/.*\// );
-}
-
-sub append( $$ ) {
- my( $self, $suffix ) = @_;
- return ( undef, 'You can not add to leaf node' ) if( $self->leaf() );
- $suffix =~ s/ //g;
- return ( undef, "Invalid ID syntax" ) unless ( ( ( $self->get() !~ /^PC\/.*\// ) && ( $suffix =~ /^[0-9a-f]{4}$/ ) ) || ( ( $self->get() =~ /^PC\/.*\// ) && ( $suffix =~ /^[0-9a-f]{8}$/ ) ) );
- return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
-}
-
-1;
+++ /dev/null
-package PciIds::Address::PciClass;
-use strict;
-use warnings;
-use PciIds::Address::Toplevel;
-use base 'PciIds::Address::Base';
-
-sub new( $ ) {
- my( $address ) = @_;
- return PciIds::Address::Toplevel::new( $address ) if( $address =~ /^PD\/?$/ );
- return bless PciIds::Address::Base::new( $address );
-}
-
-sub pretty( $ ) {
- my $self = shift;
- $_ = $self->get();
- s/^PD\/?//;
- s/\//:/g;
- my $prefix;
- if( /:.*:/ ) {
- $prefix = 'Program interface';
- } elsif( /:/ ) {
- $prefix = 'Device subclass';
- } else {
- $prefix = 'Device class';
- }
- #TODO Other levels? Are the names OK?
- return $prefix.' '.$_;
-}
-
-sub restrictRex( $$ ) {
- my( $self, $restrict ) = @_;
- my( $result ) = ( $restrict =~ /^([a-f0-9]{1,4})/ );#TODO every time?
- return $result;
-}
-
-sub leaf( $ ) {
- #TODO
-}
-
-sub append( $$ ) {
- my( $self, $suffix ) = @_;
- return ( undef, 'You can not add to leaf node' ) if( $self->leaf() );
- return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{2,2}$/ );
- return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
-}
-
-1;
+++ /dev/null
-package PciIds::Address::Toplevel;
-use strict;
-use warnings;
-use base 'PciIds::Address::Base';
-
-sub new( $ ) {
- my( $value ) = @_;
- if( $value =~ /^P[CD]\/?/ ) {
- return bless PciIds::Address::Base::new( $value );
- } else {
- return undef;
- }
-}
-
-sub pretty( $ ) {
- my $self = shift;
- if( $self->{'value'} =~ /^PC/ ) {
- return 'PCI Devices';
- } else {
- return 'PCI Device Classes';
- }
-}
-
-sub restrictRex( $$ ) {
- my( $self, $restrict ) = @_;
- return PciIds::Address::new( $self->get().'/0000' )->restrictRex( $restrict );#Nasty trick, get the right address of any subnode and try it there
-}
-
-sub leaf( $ ) {
- return 0;
-}
-
-sub append( $$ ) {
- my( $self, $suffix ) = @_;
- $suffix = lc $suffix;
- if( $self->{'value'} =~ /^PC/ ) {#PCI
- return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{4,4}$/ );
- } else {#PCI Device Class
- return ( undef, "Invalid ID syntax" ) unless ( $suffix =~ /^[0-9a-f]{2,2}$/ );
- }
- return ( PciIds::Address::Base::new( $self->{'value'} . ( ( $self->{'value'} =~ /\/$/ ) ? '' : '/' ) . $suffix ), undef );
-}
-
-sub canAddComment( $ ) { return 0; }
-
-sub defaultRestrict( $ ) {
- my( $self ) = @_;
- if( $self->get() =~ /PC/ ) {
- return "0";
- } else {
- return "";
- }
-}
-
-sub defaultRestrictList( $ ) {
- my( $self ) = @_;
- if( $self->get() =~ /PC/ ) {
- my @result;
- for(my $i = '0'; $i < '10'; ++ $i ) {
- push @result, $i;
- }
- push @result, ( 'a', 'b', 'c', 'd', 'e', 'f' );
- my @final;
- push @final, [ $_, $_ ] foreach( @result );
- push @final, [ "", "all" ];
- return \@final;
- } else {
- return [];
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Config;
-use strict;
-use warnings;
-use Startup;
-use base 'Exporter';
-
-our @EXPORT = qw(&checkConf &defConf %config &confList);
-
-our %config;
-
-sub loadConf() {
- open CONFIG, $directory."/config" or die "Config file not found. Make sure config is in the directory and the correct path is in Startup.pm\n";
- foreach( <CONFIG> ) {
- next if( /^\s*(|#.*)$/ );
- chomp;
- my( $name, $val );
- die "Invalid syntax on line $_\n" unless( ( $name, $val ) = /^\s*(.*\S)\s*=\s*(.*\S)\s*$/ );
- $val =~ s/^"(.*)"$/$1/;
- $config{$name} = $val;
- }
- close CONFIG;
-}
-
-sub checkConf( $ ) {
- my( $names ) = @_;
- foreach( @{$names} ) {
- die "Variable not set: $_\n" unless( defined $config{$_} );
- }
-}
-
-sub defConf( $ ) {
- my( $underlay ) = @_;
- foreach( keys %{$underlay} ) {
- $config{$_} = $underlay->{$_} unless( defined $config{$_} );
- }
-}
-
-sub confList( $ ) {
- my( $names ) = @_;
- my( @result );
- push @result, $config{$_} foreach( @{$names} );
- return( @result );
-}
-
-loadConf();
-
-return 1;
+++ /dev/null
-package PciIds::DBQ;
-use strict;
-use warnings;
-use base 'PciIds::DBQAny';
-
-sub new( $ ) {
- my( $dbh ) = @_;
- my $node = 'SELECT id, name, description, maincomment FROM locations WHERE parent = ? ORDER BY ';
- my $noder = 'SELECT id, name, description, maincomment FROM locations WHERE parent = ? AND id LIKE ? ORDER BY ';
- return bless PciIds::DBQAny::new( $dbh, {
- 'nodes-id' => $node.'id',
- 'nodes-name' => $node.'name',
- 'nodes-rid' => $node.'id DESC',
- 'nodes-rname' => $node.'name DESC',
- 'nodes-id-r' => $noder.'id',
- 'nodes-name-r' => $noder.'name',
- 'nodes-rid-r' => $noder.'id DESC',
- 'nodes-rname-r' => $noder.'name DESC',
- 'item' => 'SELECT parent, name, description, maincomment FROM locations WHERE id = ?',
- 'login' => 'SELECT id FROM users WHERE login = ?',
- 'email' => 'SELECT id FROM users WHERE email = ?',
- 'adduser' => 'INSERT INTO users (login, email, passwd) VALUES(?, ?, ?)',
- 'adduser-null' => 'INSERT users (email, passwd) VALUES(?, ?)',
- 'loginfomail' => 'SELECT id, passwd, logtime, lastlog FROM users WHERE email = ?',
- 'loginfoname' => 'SELECT id, passwd, logtime, lastlog, email FROM users WHERE login = ?',
- 'resetinfo' => 'SELECT id, login, passwd FROM users WHERE email = ?',
- 'changepasswd' => 'UPDATE users SET passwd = ? WHERE id = ?',
- 'setlastlog' => 'UPDATE users SET logtime = now(), lastlog = ? WHERE id = ?',
- 'rights' => 'SELECT rightId FROM rights WHERE userId = ?',
- 'newitem' => 'INSERT INTO locations (id, parent) VALUES(?, ?)',
- 'newcomment' => 'INSERT INTO history (location, owner, text, nodename, nodedescription) VALUES(?, ?, ?, ?, ?)',
- 'history' => 'SELECT history.id, history.text, history.time, history.nodename, history.nodedescription, history.seen, users.login FROM history LEFT OUTER JOIN users ON history.owner = users.id WHERE history.location = ? ORDER BY history.time',
- 'admindump' => 'SELECT
- locations.id, locations.name, locations.description, locations.maincomment, musers.login, main.text,
- history.id, history.text, history.nodename, history.nodedescription, users.login
- FROM
- locations INNER JOIN history ON history.location = locations.id
- LEFT OUTER JOIN users ON history.owner = users.id
- LEFT OUTER JOIN history AS main ON locations.maincomment = main.id
- LEFT OUTER JOIN users AS musers ON main.owner = musers.id WHERE history.seen = "0"
- ORDER BY locations.id, history.id
- LIMIT 15',#Dumps all new comments with their senders and corresponding main comments and names
- 'delete-hist' => 'DELETE FROM history WHERE id = ?',
- 'mark-checked' => 'UPDATE history SET seen = 1 WHERE id = ?',
- 'delete-item' => 'DELETE FROM locations WHERE id = ?',
- 'set-maincomment' => 'UPDATE locations SET
- maincomment = ?,
- name = ( SELECT nodename FROM history WHERE id = ? ),
- description = ( SELECT nodedescription FROM history WHERE id = ? )
- WHERE
- id = ?',
- 'profiledata' => 'SELECT email, xmpp, login, mailgather, xmppgather FROM users WHERE id = ?',
- 'pushprofile' => 'UPDATE users SET xmpp = ?, login = ?, mailgather = ?, xmppgather = ? WHERE id = ?',
- 'setemail' => 'UPDATE users SET email = ?, passwd = ? WHERE id = ?',
- 'notifuser' => 'SELECT location, recursive FROM notifications WHERE user = ? ORDER BY location',
- 'notifdata' => 'SELECT recursive, type, notification FROM notifications WHERE user = ? AND location = ?',
- 'drop-notif' => 'DELETE FROM notifications WHERE user = ? AND location = ?',
- 'new-notif' => 'INSERT INTO notifications (user, location, recursive, type, notification) VALUES (?, ?, ?, ?, ?)',
- 'notify' => 'INSERT INTO pending (user, comment, notification, reason) SELECT DISTINCT user, ?, ?, ? FROM notifications WHERE ( notification = 2 OR notification = ? ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) )',
- 'newtime-mail' => 'UPDATE users SET nextmail = FROM_UNIXTIME( UNIX_TIMESTAMP( NOW() ) + 60 * mailgather ) WHERE nextmail < NOW() AND EXISTS ( SELECT 1 FROM notifications WHERE ( notification = 0 OR notification = 2 ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) ) )',
- 'newtime-xmpp' => 'UPDATE users SET nextxmpp = FROM_UNIXTIME( UNIX_TIMESTAMP( NOW() ) + 60 * xmppgather ) WHERE nextxmpp < NOW() AND EXISTS ( SELECT 1 FROM notifications WHERE ( notification = 1 OR notification = 2 ) AND type <= ? AND ( location = ? OR ( SUBSTR( ?, 1, LENGTH( location ) ) = location ) ) )',
- 'mailout' => 'SELECT
- pending.user, users.email,
- pending.reason, history.text, history.nodename, history.nodedescription, history.time,
- auth.login, history.location, locations.name, locations.description
- FROM
- pending
- INNER JOIN users ON users.id = pending.user
- INNER JOIN history ON history.id = pending.comment
- INNER JOIN locations ON history.location = locations.id
- INNER JOIN users AS auth ON auth.id = history.owner
- WHERE
- pending.notification = 0
- AND users.nextmail <= ?
- ORDER BY
- pending.user, pending.reason, history.time, history.location',
- 'xmppout' => 'SELECT
- pending.user, users.xmpp,
- pending.reason, history.text, history.nodename, history.nodedescription, history.time,
- auth.login, history.location, locations.name, locations.description
- FROM
- pending
- INNER JOIN users ON users.id = pending.user
- INNER JOIN history ON history.id = pending.comment
- INNER JOIN locations ON history.location = locations.id
- INNER JOIN users AS auth ON auth.id = history.owner
- WHERE
- pending.notification = 1
- AND users.nextxmpp <= ?
- ORDER BY
- pending.user, pending.reason, history.time, history.location',
- 'dropnotifsxmpp' => 'DELETE FROM pending WHERE notification = 1 AND EXISTS ( SELECT 1 FROM users WHERE users.id = pending.user AND nextxmpp <= ? )',
- 'dropnotifsmail' => 'DELETE FROM pending WHERE notification = 0 AND EXISTS ( SELECT 1 FROM users WHERE users.id = pending.user AND nextmail <= ? )',
- 'time' => 'SELECT NOW()'
-
- } );
-}
-
-my %sorts = ( 'id' => 1, 'rid' => 1, 'name' => 1, 'rname' => 1 );
-
-sub nodes( $$$$ ) {
- my( $self, $parent, $args, $restrict ) = @_;
- my $q = 'id';
- $q = $args->{'sort'} if( defined( $args->{'sort'} ) && defined( $sorts{$args->{'sort'}} ) );
- if( defined( $restrict ) && ( $restrict ne "" ) ) {
- return $self->query( 'nodes-'.$q.'-r', [ $parent, $parent.'/'.$restrict.'%' ] );
- } else {
- return $self->query( 'nodes-'.$q, [ $parent ] );
- }
-}
-
-sub item( $$ ) {
- my( $self, $id ) = @_;
- my $result = $self->query( "item", [ $id ] );
- if( scalar @{$result} ) {
- return $result->[ 0 ];
- } else {
- return undef;
- }
-}
-
-sub hasLogin( $$ ) {
- my( $self, $login ) = @_;
- my $result = $self->query( 'login', [ $login ] );
- return scalar @{$result};
-}
-
-sub hasEmail( $$ ) {
- my( $self, $email ) = @_;
- my $result = $self->query( 'email', [ $email ] );
- return scalar @{$result};
-}
-
-sub addUser( $$$$ ) {
- my( $self, $login, $email, $passwd ) = @_;
- eval {
- if( ( defined $login ) && ( $login ne '' ) ) {
- $self->command( 'adduser', [ $login, $email, $passwd ] );
- } else {
- $self->command( 'adduser-null', [ $email, $passwd ] );
- }
- };
- if( $@ ) {
- return 0;
- } else {
- return $self->last();
- }
-}
-
-sub getLogInfo( $$ ) {
- my( $self, $info ) = @_;
- my $data;
- if( $info =~ /@/ ) {#An email address
- $data = $self->query( 'loginfomail', [ $info ] );
- } else {
- $data = $self->query( 'loginfoname', [ $info ] );
- }
- if( scalar @{$data} ) {
- my( $id, $passwd, $logtime, $lastlog, $email ) = @{$data->[ 0 ]};
- my $logstring;
- $logstring = "Last logged from $lastlog at $logtime" if( defined $logtime && defined $lastlog );
- $email = $info if( $info =~ /@/ );
- return( $id, $passwd, $email, $logstring );
- } else {
- return undef;
- }
-}
-
-sub rights( $$ ) {
- my( $self, $id ) = @_;
- return $self->query( 'rights', [ $id ] );
-}
-
-sub setLastLog( $$$ ) {
- my( $self, $id, $from ) = @_;
- $self->command( 'setlastlog', [ $from, $id ] );
-}
-
-sub history( $$ ) {
- my( $self, $addr ) = @_;
- return $self->query( 'history', [ $addr ] );
-}
-
-sub submitItem( $$$ ) {
- my( $self, $data, $auth ) = @_;
- my( $addr ) = ( $data->{'address'} );
- return( 'exists', undef ) if( defined( $self->item( $addr->get(), 0 ) ) );
- eval {
- $self->command( 'newitem', [ $addr->get(), $addr->parent()->get() ] );
- $self->command( 'newcomment', [ $addr->get(), $auth->{'authid'}, $data->{'text'}, $data->{'name'}, $data->{'description'} ] );
-
- };
- if( $@ ) {
- $self->rollback();
- return( 'internal: '.$@, undef );
- }
- return( '', $self->last() );
-}
-
-sub submitComment( $$$$ ) {
- my( $self, $data, $auth, $address ) = @_;
- $self->command( 'newcomment', [ $address->get(), $auth->{'authid'}, $data->{'text'}, $data->{'name'}, $data->{'description'} ], 1 );
- return $self->last();
-}
-
-sub adminDump( $ ) {
- return shift->query( 'admindump', [] );
-}
-
-sub deleteHistory( $$ ) {
- my( $self, $id ) = @_;
- $self->command( 'delete-hist', [ $id ] );
-}
-
-sub markChecked( $$ ) {
- my( $self, $id ) = @_;
- $self->command( 'mark-checked', [ $id ] );
-}
-
-sub deleteItem( $$ ) {
- my( $self, $id ) = @_;
- $self->command( 'delete-item', [ $id ] );
-}
-
-sub setMainComment( $$$ ) {
- my( $self, $location, $comment ) = @_;
- $self->command( 'set-maincomment', [ $comment, $comment, $comment, $location ] );
-}
-
-sub resetInfo( $$ ) {
- my( $self, $mail ) = @_;
- my $result = $self->query( 'resetinfo', [ $mail ] );
- if( scalar @{$result} ) {
- return ( @{$result->[0]} );
- } else {
- return undef;
- }
-}
-
-sub changePasswd( $$$ ) {
- my( $self, $id, $passwd ) = @_;
- $self->command( 'changepasswd', [ $passwd, $id ] );
-}
-
-sub profileData( $$ ) {
- my( $self, $id ) = @_;
- my %result;
- ( $result{'email'}, $result{'xmpp'}, $result{'login'}, $result{'email_time'}, $result{'xmpp_time'} ) = @{$self->query( 'profiledata', [ $id ] )->[0]};
- return \%result;
-}
-
-sub setEmail( $$$$ ) {
- my( $self, $id, $email, $passwd ) = @_;
- $self->command( 'setemail', [ $email, $passwd, $id ] );
-}
-
-sub pushProfile( $$$$$$ ) {
- my( $self, $id, $login, $xmpp, $mailgather, $xmppgather ) = @_;
- $self->command( 'pushprofile', [ $xmpp, $login, $mailgather, $xmppgather, $id ] );
-}
-
-sub notificationsUser( $$ ) {
- my( $self, $uid ) = @_;
- return $self->query( 'notifuser', [ $uid ] );
-}
-
-sub getNotifData( $$$ ) {
- my( $self, $uid, $location ) = @_;
- my $result = $self->query( 'notifdata', [ $uid, $location ] );
- if( @{$result} ) {
- my( $recursive, $notification, $way ) = @{$result->[0]};
- return {
- 'recursive' => $recursive,
- 'notification' => $notification,
- 'way' => $way };
- } else {
- return { 'recursive' => 1 };
- }
-}
-
-sub submitNotification( $$$$ ) {
- my( $self, $uid, $location, $data ) = @_;
- $self->command( 'drop-notif', [ $uid, $location ] );
- $self->command( 'new-notif', [ $uid, $location, $data->{'recursive'}, $data->{'notification'}, $data->{'way'} ] ) unless( $data->{'notification'} == 3 );
-}
-
-sub pushNotifications( $$$$$ ) {
- my( $self, $location, $comment, $priority, $reason ) = @_;
- $self->command( 'notify', [ $comment, 0, $reason, 0, $priority, $location, $location ] );
- $self->command( 'notify', [ $comment, 1, $reason, 1, $priority, $location, $location ] );
- $self->command( 'newtime-mail', [ $priority, $location, $location ] );
- $self->command( 'newtime-xmpp', [ $priority, $location, $location ] );
-}
-
-sub mailNotifs( $$ ) {
- my( $self, $time ) = @_;
- return $self->query( 'mailout', [ $time ] );
-}
-
-sub xmppNotifs( $$ ) {
- my( $self, $time ) = @_;
- return $self->query( 'xmppout', [ $time ] );
-}
-
-sub time( $ ) {
- my( $self ) = @_;
- return $self->query( 'time', [] )->[0]->[0];
-}
-
-sub dropNotifs( $$ ) {
- my( $self, $time ) = @_;
- $self->command( 'dropnotifsmail', [ $time ] );
- $self->command( 'dropnotifsxmpp', [ $time ] );
-}
-
-1;
+++ /dev/null
-package PciIds::DBQAny;
-use strict;
-use warnings;
-use DBI;
-
-sub new( $$ ) {
- my( $dbh, $queries ) = @_;
- my %qs;
- foreach( keys %{$queries} ) {
- $qs{$_} = $dbh->prepare( $queries->{$_} );
- }
- return bless {
- "dbh" => $dbh,
- "queries" => \%qs
- };
-}
-
-sub queryAll( $$$$ ) {
- my( $self, $name, $params, $fetch ) = @_;
- my $q = $self->{'queries'}->{$name};
- $q->execute( @{$params} );#Will die automatically
- if( $fetch ) {
- my @result = @{$q->fetchall_arrayref()};#Copy the array, finish() deletes the content
- $q->finish();
- return \@result;
- }
-}
-
-sub query( $$$ ) {
- my( $self, $name, $params ) = @_;
- return queryAll( $self, $name, $params, 1 );
-}
-
-sub command( $$$ ) {
- my( $self, $name, $params ) = @_;
- queryAll( $self, $name, $params, 0 );
-}
-
-sub commit( $ ) {
- shift->{'dbh'}->commit();
-}
-
-sub rollback( $ ) {
- shift->{'dbh'}->rollback();
-}
-
-sub last( $ ) {
- return shift->{'dbh'}->last_insert_id( undef, undef, undef, undef );
-}
-
-sub dbh( $ ) { return shift->{'dbh'}; }
-
-1;
+++ /dev/null
-package PciIds::Db;
-use strict;
-use warnings;
-use base 'Exporter';
-use PciIds::Config;
-use DBI;
-
-our @EXPORT = qw( &connectDb );
-
-sub connectDb() {
- my ( $uri, $user, $passwd ) = confList( [ "dburi", "dbuser", "dbpasswd" ] );
- my $result = DBI->connect( $uri, $user, $passwd, { 'AutoCommit' => 0, 'RaiseError' => 1, 'PrintError' => 0 } ) or die "Could not connect to database $uri (".DBI->errstr.")\n";
-}
-
-checkConf( [ "dbuser", "dbpasswd" ] );
-defConf( { "dbname" => "pciids" } );
-defConf( { "dburi" => "dbi:mysql:".$config{"dbname"} } );
-
-return 1;
+++ /dev/null
-package PciIds::Email;
-use strict;
-use warnings;
-use PciIds::Config;
-use base 'Exporter';
-
-our @EXPORT = qw(&sendMail);
-
-checkConf( [ 'from_addr', 'sendmail' ] );
-defConf( { 'sendmail' => '/usr/sbin/sendmail' } );
-
-sub sendMail( $$$ ) {
- my( $to, $subject, $body ) = @_;
- my( $from, $sendmail ) = confList( [ 'from_addr', 'sendmail' ] );
- $body =~ s/^\.$/../gm;
- open SENDMAIL, "|$sendmail -f$from $to" or die 'Can not send mail';
- print SENDMAIL "From: $from\n".
- "To: $to\n".
- "Subject: $subject\n".
- "Content-Type: text/plain; charset=\"utf8\"\n".
- "\n".
- $body."\n.\n";
- close SENDMAIL or die "Sending mail failed: $!, $?";
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Admin;
-use strict;
-use warnings;
-use PciIds::Users;
-use PciIds::Html::Util;
-use PciIds::Html::Users;
-use PciIds::Html::Forms;
-use PciIds::Notifications;
-use PciIds::Log;
-use Apache2::Const qw(:common :http);
-
-sub genNewAdminForm( $$$$ ) {
- my( $req, $args, $tables, $error ) = @_;
- genHtmlHead( $req, 'Administration ‒ pending events', undef );
- print "<h1>Administration ‒ pending events</h1>\n";
- print "<div class='error'>".$error."</div>\n" if( defined $error );
- print '<form name="admin" id="admin" class="admin" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args )."?action=admin\">\n";
- my $lastId;
- my $started = 0;
- my $cnt = 0;
- my $hiscnt = 0;
- my $subcnt;
- foreach( @{$tables->adminDump()} ) {
- my( $locId, $actName, $actDescription, $actCom, $actUser, $actText,
- $com, $text, $name, $description, $user ) = @{$_};
- if( !defined( $lastId ) || ( $lastId ne $locId ) ) {
- $lastId = $locId;
- print "</div>\n" if( $started );
- $started = 1;
- print "<div class='".( defined( $actCom ) ? 'item' : 'unnamedItem' )."'>\n";
- my $addr = PciIds::Address::new( $locId );
- print "<h3><a href='/read/".$addr->get()."/'>".encode( $addr->pretty() )."</a></h3>\n";
- print htmlDiv( 'name', '<p>'.encode( $actName ) ) if( defined( $actName ) );
- print htmlDiv( 'description', '<p>'.encode( $actDescription ) ) if( defined( $actDescription ) );
- print '<p>'.encode( $actText ) if( defined( $actText ) );
- print '<p><a class="navigation" href="/read/'.$addr->parent()->get().'/">'.encode( $addr->parent()->pretty() )."</a>" if( defined( $addr->parent() ) );
- print htmlDiv( 'author', '<p>'.encode( $actUser ) ) if( defined( $actUser ) );
- print "<input type='hidden' name='subcnt-$cnt' value='$subcnt'>\n" if( defined( $subcnt ) );
- $subcnt = 0;
- $cnt++;
- print "<input type='hidden' name='loc-$cnt' value='".$addr->get()."'>\n";
- print "<p><input type='radio' name='action-$cnt' value='ignore' checked='checked'> I will decide later.\n";
- if( defined( $actCom ) ) {
- print "<br><input type='radio' name='action-$cnt' value='keep'> Keep current name.\n";
- }
- print "<br><input type='radio' name='action-$cnt' value='delete'> Delete item.\n";
- print "<br>Add comment:\n";
- print "<br><table>\n";
- print "<tr><td>Set name:<td><input type='text' name='name-$cnt' maxlength='200'>\n";
- print "<tr><td>Set description:<td><input type='text' name='description-$cnt' maxlength='1024'>\n";
- print "<tr><td>Text:<td><textarea name='text-$cnt' rows='2'></textarea>\n";
- print "</table>\n";
- }
- print "<div class='unseen-comment'>\n";
- print "<p class='name'>".encode( $name ) if( defined( $name ) );
- print "<p class='description'>".encode( $description ) if( defined( $description ) );
- print '<p>'.encode( $text ) if( defined( $text ) );
- print "<p class='author'>".encode( $user ) if( defined( $user ) );
- print "<p><input type='radio' name='action-$cnt' value='set-$com'> Use this one.\n" if( defined( $name ) && ( $name ne "" ) );
- $hiscnt ++;
- print "<br><input type='checkbox' name='delete-$hiscnt' value='delete-$com'> Delete comment.\n";
- print "</div>\n";
- $subcnt ++;
- print "<input type='hidden' name='sub-$cnt-$subcnt' value='$com'>\n";
- }
- print "<input type='hidden' name='subcnt-$cnt' value='$subcnt'>\n" if( defined( $subcnt ) );
- if( $started ) {
- print "</div>\n" if( $started );
- print "<p><input type='submit' name='submit' value='Submit'>\n";
- print "<input type='hidden' name='max-cnt' value='$cnt'><input type='hidden' name='max-hiscnt' value='$hiscnt'>\n";
- } else {
- print "<p>No pending comments.\n";
- }
- print "</form>\n";
- genHtmlTail();
- return OK;
-}
-
-sub adminForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined( $auth->{'authid'} ) && hasRight( $auth->{'accrights'}, 'validate' ) ) {
- return genNewAdminForm( $req, $args, $tables, undef );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-sub markAllChecked( $$$$ ) {
- my( $tables, $itemNum, $deleted, $authid ) = @_;
- my $i;
- my $subcnt = getFormValue( "subcnt-$itemNum", 0 );
- for( $i = 1; $i <= $subcnt; ++ $i ) {
- my $id = getFormValue( "sub-$itemNum-$i", undef );
- next unless( defined( $id ) );
- next if( $deleted->{$id} );#Do not update this one, already deleted
- $tables->markChecked( $id );
- tulog( $authid, "Comment checked $id" );
- }
-}
-
-sub submitAdminForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- my $authid = $auth->{'authid'};
- if( defined( $authid ) && hasRight( $auth->{'accrights'}, 'validate' ) ) {
- my $errors = '';
- my %deleted;
- my $maxcnt = getFormValue( 'max-cnt', 0 );
- my $maxhiscnt = getFormValue( 'max-hiscnt', 0 );
- for( my $i = 1; $i <= $maxhiscnt; $i ++ ) {
- my $del = getFormValue( "delete-$i", "" );
- $del =~ s/^delete-//;
- if( $del ne '' ) {
- $deleted{$del} = 1;
- $tables->deleteHistory( $del );
- tulog( $authid, "Comment deleted $del" );
- }
- }
- for( my $i = 1; $i <= $maxcnt; $i ++ ) {
- my $action = getFormValue( "action-$i", 'ignore' );
- my $loc = getFormValue( "loc-$i", undef );
- next unless( defined( $loc ) );
- my( $text, $name, $description ) = (
- getFormValue( "text-$i", undef ),
- getFormValue( "name-$i", undef ),
- getFormValue( "description-$i", undef ) );
- if( defined( $description ) && ( $description ne '' ) && ( !defined( $name ) || ( length $name < 3 ) ) ) {
- if( $errors eq '' ) {
- $errors = '<p>';
- } else {
- $errors .= '<br>';
- }
- $errors .= "$loc - You need to provide name if you provide description\n";
- next;
- }
- if( ( defined( $name ) && ( length $name >= 3 ) ) || ( defined( $text ) && ( $text ne '' ) ) ) { #Submited comment
- my $addr = PciIds::Address::new( $loc );
- my $comId = $tables->submitComment( { 'name' => $name, 'description' => $description, 'explanation' => $text }, $auth, $addr );
- my $main = defined $name && ( $name ne '' );
- notify( $tables, $addr->get(), $comId, $main ? 2 : 0, $main ? 2 : 1 );
- $tables->markChecked( $comId );
- tulog( $authid, "Comment created (admin) $comId $loc ".logEscape( $name )." ".logEscape( $description )." ".logEscape( $text ) );
- if( defined( $name ) && ( length $name >= 3 ) ) {
- $tables->setMainComment( $loc, $comId );
- tulog( $authid, "Item main comment changed $loc $comId" );
- $action = 'keep';
- }
- }
- next if( $action eq 'ignore' );
- if( $action eq 'keep' ) {
- markAllChecked( $tables, $i, \%deleted, $authid );
- } elsif( $action eq 'delete' ) {
- eval {
- $tables->deleteItem( $loc );
- tulog( $authid, "Item deleted (recursive) $loc" );
- } #Ignore if it was already deleted by superitem
- } elsif( my( $setId ) = ( $action =~ /set-(.*)/ ) ) {
- next if( $deleted{$setId} );
- $tables->setMainComment( $loc, $setId );
- notify( $tables, $loc, $setId, 2, 2 );
- tulog( $authid, "Item main comment changed $loc $setId" );
- markAllChecked( $tables, $i, \%deleted, $authid );
- }
- }
- return genNewAdminForm( $req, $args, $tables, $errors );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Changes;
-use strict;
-use PciIds::Html::Users;
-use PciIds::Html::List;
-use PciIds::Html::Util;
-use PciIds::Html::Forms;
-use PciIds::Notifications;
-use PciIds::Log;
-use Apache2::Const qw(:common :http);
-
-sub genNewItemForm( $$$$$ ) {
- my( $req, $args, $tables, $error, $values ) = @_;
- my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
- return NOT_FOUND unless( $ok );
- my $prettyAddr = encode( $address->pretty() );
- genHtmlHead( $req, "$prettyAddr - add new item", undef );
- print "<h1>$prettyAddr - add new item</h1>\n";
- print "<div class='error'>$error</div>\n" if( defined $error );
- print "<form name='newitem' id='newitem' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=newitem'>\n<table>";
- genFormEx( [ [ 'input', 'Id:', 'text', 'id', 'maxlength="50"' ],
- [ 'input', 'Name:', 'text', 'name', 'maxlength="200"' ],
- [ 'input', 'Description*:', 'text', 'description', 'maxlength="1024"' ],
- [ 'textarea', 'Text*:', undef, 'text', 'rows="5" cols="50"' ],
- [ 'input', '', 'submit', 'submit', 'value="Submit"' ] ], $values );
- print '</table></form>';
- print '<p>Items marked with * are optional.';
- genHtmlTail();
- return OK;
-}
-
-sub newItemForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined $auth->{'authid'} ) {#Logged in alright
- return genNewItemForm( $req, $args, $tables, undef, {} );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-sub newItemSubmit( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined $auth->{'authid'} ) {
- my( $pok, $parent, $pname, $pdescription, $paddress ) = loadItem( $tables, $req->uri() );
- return NOT_FOUND unless( $pok );
- my( $data, $error ) = getForm( {
- 'id' => sub{ return ( length shift ) ? undef : 'Please, provide the ID'; }, #Checked at the bottom and added as address
- 'name' => sub {
- my( $name ) = @_;
- return 'Too short for a name' if( length $name < 3 );
- return 'Lenght limit of the name is 200 characters' if( length $name > 200 );
- return undef;
- },
- 'description' => sub { return ( length shift > 1024 ) ? 'Description can not be longer than 1024 characters' : undef; },
- 'text' => sub { return ( length shift > 1024 ) ? 'Text can not be longer than 1024 characters' : undef; }
- }, [ sub { my( $data ) = @_;
- my $errstr;
- return undef unless( length $data->{'id'} );#No address, so let it for the first check
- ( $data->{'address'}, $errstr ) = $paddress->append( $data->{'id'} );
- return $errstr;
- }, sub { return $paddress->canAddItem() ? undef : 'Can not add items here'; } ] );
- return genNewItemForm( $req, $args, $tables, $error, $data ) if( defined $error );
- my( $result, $comName ) = $tables->submitItem( $data, $auth );
- if( $result eq 'exists' ) {
- genHtmlHead( $req, 'ID collision', undef );
- print '<h1>ID collision</h1>';
- print '<p>This ID already exists. Have a look <a href="/read/'.$data->{'address'}->get().'?action=list">at it</a>';
- genHtmlTail();
- return OK;
- } elsif( $result ) {
- die "Failed to submit new item: $result\n";
- }
- notify( $tables, $data->{'address'}->get(), $comName, 2, 0 );
- tulog( $auth->{'authid'}, "Item created ".$data->{'address'}->get()." ".logEscape( $data->{'name'} )." ".logEscape( $data->{'description'} )." ".logEscape( $data->{'text'} )." $comName" );
- return HTTPRedirect( $req, '/read/'.$data->{'address'}->get().'?action=list' );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-sub genNewCommentForm( $$$$$ ) {
- my( $req, $args, $tables, $error, $values ) = @_;
- my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
- return NOT_FOUND unless( $ok );
- my $prettyAddr = encode( $address->pretty() );
- genHtmlHead( $req, "$prettyAddr - add a comment to discussion", undef );
- print "<h1>$prettyAddr - add a comment to discussion</h1>\n";
- print "<div class='error'>$error</div>\n" if( defined $error );
- print "<form name='newcomment' id='newitem' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=newcomment'>\n<table>";
- genFormEx( [ [ 'textarea', 'Text:', undef, 'text', 'rows="5" cols="50"' ],
- [ 'input', 'Name*:', 'text', 'name', 'maxlength="200"' ],
- [ 'input', 'Description*:', 'text', 'description', 'maxlength="1024"' ],
- [ 'input', '', 'submit', 'submit', 'value="Submit"' ] ], $values );
- print '</table></form>';
- print '<p>Items marked with * are optional, use them only if you want to change the name and description.';
- print '<p>If you specify description must include name too.';
- genHtmlTail();
- return OK;
-}
-
-sub newCommentForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined $auth->{'authid'} ) {
- return genNewCommentForm( $req, $args, $tables, undef, {} );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-sub newCommentSubmit( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined $auth->{'authid'} ) {
- my( $ok, $parent, $name, $description, $address ) = loadItem( $tables, $req->uri() );
- return NOT_FOUND unless( $ok );
- my( $data, $error ) = getForm( {
- 'name' => sub { return ( length shift > 200 ) ? 'Lenght limit of the name is 200 characters' : undef; },
- 'description' => sub { return ( length shift > 1024 ) ? 'Description can not be longer than 1024 characters' : undef; },
- 'text' => sub {
- my( $expl ) = @_;
- return 'Text can not be longer than 1024 characters' if ( length $expl > 1024 );
- return 'You must provide the text of comment' unless( length $expl );
- return undef;
- }
- }, [ sub { my( $data ) = @_;
- return 'You must provide name too' if( ( length $data->{'description'} ) && ( ! length $data->{'name'} ) );
- return undef;
- }, sub { return $address->canAddComment() ? undef : 'You can not discuss this item'; } ] );
- return genNewCommentForm( $req, $args, $tables, $error, $data ) if( defined $error );
- my $hid = $tables->submitComment( $data, $auth, $address );
- tulog( $auth->{'authid'}, "Comment created $hid ".$address->get()." ".logEscape( $data->{'name'} )." ".logEscape( $data->{'description'} )." ".logEscape( $data->{'text'} ) );
- notify( $tables, $address->get(), $hid, ( defined $name && ( $name ne '' ) ) ? 1 : 0, 1 );
- return HTTPRedirect( $req, '/read/'.$address->get().'?action=list' );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Debug;
-use strict;
-use warnings;
-use Apache2::Const qw(:common :http);
-use PciIds::Html::Util;
-
-sub test( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- genHtmlHead( $req, 'Test', undef );
- print '<p>Logged in: '.$auth->{'authid'} if( defined $auth->{'authid'} );
- print $auth->{'logerror'} if( defined $auth->{'logerror'} );
- return OK unless defined $auth->{'authid'};
- print "<p>";
- foreach( keys %ENV ) {
- print encode( "$_: $ENV{$_}<br>" );
- }
- genHtmlTail();
- return OK;
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Format;
-use strict;
-use warnings;
-use PciIds::Html::Util;
-use base 'Exporter';
-
-our @EXPORT = qw(&htmlFormatTable);
-
-sub htmlFormatTable( $$$$$$ ) {
- my( $data, $cols, $headers, $funcs, $filter, $trHead ) = @_;
- $trHead = sub { return ''; } unless( defined $trHead );
- foreach my $line ( @{$data} ) {
- next unless( &{$filter}( $line ) );
- my $i;
- print '<tr'.&{$trHead}( $line ).'>';
- for( $i = 0; $i < $cols; $i ++ ) {
- my( $header, $func );
- if( ( scalar( @{$headers} ) > $i ) && defined( $headers->[ $i ] ) ) {
- $header = $headers->[ $i ];
- } else {
- $header = '<td>';
- }
- if( ( scalar( @{$funcs} ) > $i ) && defined( $funcs->[ $i ] ) ) {
- $func = $funcs->[ $i ];
- } else {
- $func = \&encode;
- }
- my $data = &{$func}( $line->[ $i ] );
- $data = "" unless( defined( $data ) );
- print $header.$data.'</td>';
- }
- print "</tr>\n";
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Forms;
-use strict;
-use warnings;
-use base 'Exporter';
-use CGI;
-use HTML::Entities;
-
-our @EXPORT = qw(&genForm &getForm &genFormEx &getFormValue &genRadios);
-
-sub genFormEx( $$ ) {
- my( $inputs, $values ) = @_;
- foreach( @{$inputs} ) {
- my( $kind, $label, $type, $name, $other ) = @{$_};
- $other = '' unless( defined $other );
- print '<tr><td>'.$label.'<td><'.$kind.( ( defined $type ) ? ' type="'.$type.'"' : '' ).' name="'.$name.'" '.$other.( defined( $values->{$name} && ( $label ne 'textarea' ) ) ? 'value="'.encode_entities( $values->{$name} ).'" ' : '' ).">\n";
- if( $kind eq 'textarea' ) {
- print encode_entities( $values->{$name} ) if( defined( $values->{$name} ) );
- print "</$kind>\n";
- }
- }
-}
-
-sub genForm( $$ ) {
- my( $inputs, $values ) = @_;
- my @transformed;
- foreach( @{$inputs} ) {
- my @ln = @{$_};
- unshift @ln, "input";
- push @transformed, \@ln;
- }
- genFormEx( \@transformed, $values );
-}
-
-sub getFormValue( $$ ) {
- my( $name, $default ) = @_;
- my $result = CGI::param( $name );
- $result = $default unless( defined( $result ) );
- return $result;
-}
-
-sub getForm( $$ ) {
- my( $data, $checks ) = @_;
- my %result;
- my @errors;
- foreach( keys %{$data} ) {
- my $d = CGI::param( $_ );
- my $sub = $data->{$_};
- my ( $err, $newval ) = &{$sub}( $d ) if( defined $sub );
- $d = $newval if( defined $newval );
- push @errors, $err if( defined $err );
- $result{$_} = $d;
- }
- foreach( @{$checks} ) {
- my $err = &{$_}( \%result );
- push @errors, $err if( defined $err );
- }
- return ( \%result, ( @errors ) ? ( join '<p>', ( '', @errors ) ) : undef );
-}
-
-sub genRadios( $$$ ) {
- my( $list, $name, $default ) = @_;
- foreach( @{$list} ) {
- my( $label, $value ) = @{$_};
- print "<input type='radio' name='$name' value='$value'".( $value eq $default ? " checked='checked' " : "" )."> $label<br>\n";
- }
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Handler;
-use strict;
-use warnings;
-use PciIds::Db;
-use PciIds::Html::Tables;
-use PciIds::Html::Util;
-use PciIds::Html::List;
-use PciIds::Html::Users;
-use PciIds::Html::Debug;
-use PciIds::Html::Changes;
-use PciIds::Html::Admin;
-use PciIds::Html::Notifications;
-use PciIds::Notifications;
-use Apache2::Const qw(:common :http);
-
-my $dbh = connectDb();
-my $tables = PciIds::Html::Tables::new( $dbh );
-
-my %handlers = (
- 'GET' => {
- 'list' => \&PciIds::Html::List::list,#List items
- '' => \&PciIds::Html::List::list,
- #Database changes
- 'newitem' => \&PciIds::Html::Changes::newItemForm,
- 'newcomment' => \&PciIds::Html::Changes::newCommentForm,
- #Registering users
- 'register' => \&PciIds::Html::Users::registerForm,
- 'register-confirm' => \&PciIds::Html::Users::confirmForm,
- #Logins
- 'login' => \&PciIds::Html::Users::loginForm,
- 'logout' => \&PciIds::Html::Users::logout,
- 'respass' => \&PciIds::Html::Users::resetPasswdForm,
- 'respass-confirm' => \&PciIds::Html::Users::resetPasswdConfirmForm,
- #User profile
- 'profile' => \&PciIds::Html::Users::profileForm,
- #Admin
- 'admin' => \&PciIds::Html::Admin::adminForm,
- #Some debug
- 'test' => \&PciIds::Html::Debug::test,
- #Notifications
- 'notifications' => \&PciIds::Html::Notifications::notifForm
- },
- 'POST' => {
- 'newitem' => \&PciIds::Html::Changes::newItemSubmit,
- 'newcomment' => \&PciIds::Html::Changes::newCommentSubmit,
- 'register' => \&PciIds::Html::Users::registerSubmit,
- 'register-confirm' => \&PciIds::Html::Users::confirmSubmit,
- 'login' => \&PciIds::Html::Users::loginSubmit,
- 'respass' => \&PciIds::Html::Users::resetPasswdFormSubmit,
- 'respass-confirm' => \&PciIds::Html::Users::resetPasswdConfirmFormSubmit,
- 'profile' => \&PciIds::Html::Users::profileFormSubmit,
- 'admin' => \&PciIds::Html::Admin::submitAdminForm,
- 'notifications' => \&PciIds::Html::Notifications::notifFormSubmit
- }
-);
-
-sub handler( $$ ) {
- my( $req, $hasSSL ) = @_;
- return DECLINED if( $req->uri() =~ /^\/(static)\// );
- my $args = parseArgs( $req->args() );
- my $action = $args->{'action'};
- $action = '' unless( defined $action );
- my $method = $handlers{$req->method()};
- return HTTP_METHOD_NOT_ALLOWED unless( defined $method );#Can't handle this method
- my $sub = $method->{$action};
- return HTTP_BAD_REQUEST unless( defined $sub );#I do not know this action for given method
- my $auth = checkLogin( $req, $tables );#Check if logged in
- $auth->{'ssl'} = $hasSSL;
- my $result = &{$sub}( $req, $args, $tables, $auth );#Just do the right thing
- $tables->commit();
- return $result;
-}
-
-1;
+++ /dev/null
-package PciIds::Html::HandlerPlain;
-use strict;
-use warnings;
-use PciIds::Html::Handler;
-
-sub handler( $ ) {
- return PciIds::Html::Handler::handler( shift, 0 );
-}
-
-1;
+++ /dev/null
-package PciIds::Html::HandlerSSL;
-use strict;
-use warnings;
-use PciIds::Html::Handler;
-
-sub handler( $ ) {
- return PciIds::Html::Handler::handler( shift, 1 );
-}
-
-1;
+++ /dev/null
-package PciIds::Html::List;
-use strict;
-use warnings;
-use PciIds::Address;
-use PciIds::Html::Util;
-use Apache2::Const qw(:common :http);
-use base 'Exporter';
-
-our @EXPORT = qw(&loadItem);
-
-sub loadItem( $$ ) {
- my( $tables, $uri ) = @_;
- my $address = PciIds::Address::new( $uri );
- return ( 0 ) unless( defined $address );
- my $item = $tables->item( $address->get() );
- return ( 0 ) unless( defined $item );
- my( $parent, $name, $description, $maincomment ) = @{$item};
- return ( 1, $parent, $name, $description, $address, $maincomment );
-}
-
-sub list( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- my( $ok, $parent, $name, $description, $address, $mid ) = loadItem( $tables, $req->uri() );
- return NOT_FOUND unless( $ok );
- my $id = $address->pretty();
- genHtmlHead( $req, $id, undef );
- print '<h1>'.encode( $id ).'</h1>';
- genMenu( $address, $args, $auth );
- print htmlDiv( 'name', '<p>'.encode( $name ) ) if( defined( $name ) );
- print htmlDiv( 'description', '<p>'.encode( $description ) ) if( defined( $description ) );
- print '<p><a class="navigation" href="/read/'.$address->parent()->get().'/">'.encode( $address->parent()->pretty() )."</a>" if( defined( $address->parent() ) );
- my $diss = 0;
- my $comment;
- foreach $comment ( @{$tables->history( $address->get() )} ) {
- unless( $diss ) {
- print "<div class='discussion'>\n<h2>Discussion</h2>";
- $diss = 1;
- }
- my( $id, $text, $time, $name, $description, $seen, $user ) = @{$comment};
- my $type = $seen ? 'comment' : 'unseen-comment';
- $type = 'main-comment' if( defined( $mid ) && ( $id == $mid ) );
- print "<div class='$type'>\n";
- print "<p class='itemname'>Name: ".encode( $name )."\n" if( defined( $name ) && ( $name ne '' ) );
- print "<p class='itemdescription'>Description: ".encode( $description )."\n" if( defined( $description ) && ( $description ne '' ) );
- if( defined( $text ) && ( $text ne '' ) ) {
- $text = encode( $text );
- $text =~ s/\n/<br>/g;
- print "<p class='comment-text'>$text\n";
- }
- print "<p class='author'>".encode( $user )."\n" if( defined( $user ) );
- print "<p class='time'>".encode( $time )."\n";
- print "</div>\n";
- }
- print "</div>\n" if( $diss );
- unless( $address->leaf() ) {
- print "<h2>Subitems</h2>\n";
- my $restricts = $address->defaultRestrictList();
- if( scalar @{$restricts} ) {
- print "<p>";
- my $url = '/read/'.$address->get().buildExcept( 'restrict', $args ).'?restrict=';
- foreach( @{$restricts} ) {
- print "<a href='".$url.$_->[0]."'>".$_->[1]."</a> ";
- }
- }
- my $url = '/read/'.$address->get().buildExcept( 'sort', $args );
- my $sort = ( $args->{'sort'} or 'id' );
- my( $sort_id, $sort_name ) = ( ( $sort eq 'id' ? 'rid' : 'id' ), ( $sort eq 'name' ? 'rname' : 'name' ) );
- genTableHead( 'subnodes', [ '<a href="'.$url.'?sort='.$sort_id.'">Id</a>', '<a href="'.$url.'?sort='.$sort_name.'">Name</a>', 'Description' ] );
- $args->{'restrict'} = $address->defaultRestrict() unless( defined( $args->{'restrict'} ) );
- $tables->nodes( $address->get(), $args );
- genTableTail();
- }
- genHtmlTail();
- return OK;
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Notifications;
-use strict;
-use warnings;
-use PciIds::Html::Util;
-use PciIds::Html::Forms;
-use PciIds::Html::Users;
-use PciIds::Address;
-use Apache2::Const qw(:common :http);
-
-sub genNotifForm( $$$$$$ ) {
- my( $req, $args, $tables, $auth, $error, $data ) = @_;
- my $addr = PciIds::Address::new( $req->uri() );
- genHtmlHead( $req, $addr->pretty().' - notifications', undef );
- print "<h1>".$addr->pretty()." - notifications</h1>\n";
- print "<div class='error'>$error</div>\n" if( defined $error );
- my $uri = $addr->get();
- my $notifs = $tables->notificationsUser( $auth->{'authid'} );
- my $started;
- foreach( @{$notifs} ) {
- my( $location, $recursive ) = @{$_};
- if( ( substr( $uri, 0, length $location ) eq $location ) && $recursive && ( length $location < length $uri ) ) {
- unless( $started ) {
- print "<div class='navigation'><h2>Item already covered by</h2><ul>\n";
- $started = 1;
- }
- print "<li><a href='/$location".buildArgs( $args )."'>".PciIds::Address::new( $location )->pretty()."</a>\n";
- }
- }
- print "</ul></div>\n" if( $started );
- print "<form name='notifications' id='notifications' method='POST' action='".setAddrPrefix( $req->uri(), "mods" ).buildExcept( 'action', $args )."?action=notifications'>\n";
- print "<p><input type='checkbox' value='recursive' name='recursive'".( $data->{'recursive'} ? " checked='checked'" : "" )."> Recursive\n";
- print "<h3>Notification level</h3>\n";
- print "<p>\n";
- genRadios( [ [ 'None', '3' ], [ 'Main comment & new subitem', '2' ], [ 'Description', '1' ], [ 'Comment', '0' ] ], 'notification', ( defined $data->{'notification'} ) ? $data->{'notification'} : '3' );
- print "<h3>Notification way</h3>\n";
- print "<p>\n";
- genRadios( [ [ 'Email', '0' ], [ 'Xmpp', '1' ], [ 'Both', '2' ] ], 'way', ( defined $data->{'way'} ) ? $data->{'way'} : '0' );
- print "<p><input type='submit' value='Submit' name='submit'>\n";
- print "</form>\n";
- if( @{$notifs} ) {
- print "<div class='navigation'><h3>All notifications</h3><ul>\n";
- foreach( @{$notifs} ) {
- my( $location ) = @{$_};
- print "<li><a href='/$location".buildArgs( $args )."'>".PciIds::Address::new( $location )->pretty()."</a>\n";
- }
- print "</ul></div>\n";
- }
- print "<a class='navigation' href='".setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list'>Back to browsing</a>\n";
- genHtmlTail();
- return OK;
-}
-
-sub notifForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- if( defined $auth->{'authid'} ) {
- return genNotifForm( $req, $args, $tables, $auth, undef, $tables->getNotifData( $auth->{'authid'}, PciIds::Address::new( $req->uri() )->get() ) );
- } else {
- return notLoggedComplaint( $req, $args, $auth );
- }
-}
-
-sub range( $$$ ) {
- my( $value, $name, $max ) = @_;
- return ( "Invalid number in $name", 0 ) if $value !~ /\d+/;
- return ( "Invalid range in $name", 0 ) if ( $value < 0 ) || ( $value > $max );
- return undef;
-}
-
-sub notifFormSubmit( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
- my( $data, $error ) = getForm( {
- 'notification' => sub { return range( shift, "notification", 3 ); },
- 'way' => sub { return range( shift, "way", 2 ); },
- 'recursive' => sub {
- my $value = shift;
- return ( undef, 1 ) if ( defined $value ) && ( $value eq 'recursive' );
- return ( undef, 0 ) if ( !defined $value ) || ( $value eq '' );
- return ( 'Invalid value in recursive', 0 );
- }
- }, [] );
- return genNotifForm( $req, $args, $tables, $auth, $error, $data ) if defined $error;
- $tables->submitNotification( $auth->{'authid'}, PciIds::Address::new( $req->uri() )->get(), $data );
- return HTTPRedirect( $req, setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list" );
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Tables;
-use strict;
-use warnings;
-use base 'PciIds::DBQ';
-use PciIds::Html::Format;
-use PciIds::Address;
-
-sub new( $ ) {
- my( $dbh ) = @_;
- return bless PciIds::DBQ::new( $dbh );
-}
-
-sub formatLink( $ ) {
- my $address = PciIds::Address::new( shift );
- return '<a href="/read/'.$address->get().'">'.$address->tail().'</a>';
-}
-
-sub nodes( $$$ ) {
- my( $self, $parent, $args ) = @_;
- my $restrict = $args->{'restrict'};
- $restrict = '' unless( defined $restrict );
- $restrict = PciIds::Address::new( $parent )->restrictRex( $restrict );#How do I know if the restrict is OK?
- htmlFormatTable( PciIds::DBQ::nodes( $self, $parent, $args, $restrict ), 3, [], [ \&formatLink ], sub { 1; }, sub { return ' class="'.( defined( shift->[ 3 ] ) ? 'item' : 'unnamedItem' ).'"'; } );
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Users;
-use strict;
-use warnings;
-use PciIds::Html::Util;
-use PciIds::Html::Forms;
-use PciIds::Email;
-use PciIds::Users;
-use CGI;
-use CGI::Cookie;
-use Apache2::Const qw(:common);
-use Apache2::SubRequest;
-use APR::Table;
-
-use base 'Exporter';
-
-our @EXPORT = qw(&checkLogin ¬LoggedComplaint);
-
-sub genRegisterForm( $$$$ ) {
- my( $req, $args, $error, $values ) = @_;
- genHtmlHead( $req, 'Register a new user', undef );
- print '<h1>Register a new user</h1>';
- print '<div class="error">'.$error.'</div>' if( defined $error );
- print '<form name="register" id="register" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=register">
- <table>';
- genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
- [ '', 'submit', 'register', 'value="Register"' ] ], $values );
- print '</table></form>';
- genHtmlTail();
- return OK;
-}
-
-sub registerForm( $$ ) {#Form for registering a new user
- my( $req, $args ) = @_;
- return genRegisterForm( $req, $args, undef, {} );
-}
-
-sub loginCheck( $$ ) {
- my( $login, $tables ) = @_;
- return undef if( ( not defined $login ) || ( $login eq '' ) );#empty login is ok
- return 'Login too long' if( ( length $login ) > 50 );
- return 'Login contains invalid characters' unless( $login =~ /^[-_a-zA-Z0-9]+$/ );
- return 'This login already exists' if( $tables->hasLogin( $login ) );
- return undef;
-}
-
-sub emailCheck( $$ ) {
- my( $email, $tables ) = @_;
- my $newmail;
- return 'Does not look like an email address' unless ( ( $newmail ) = ( $email =~ /^([^,? "'`;]+@[^@,?\/ "'`;]+)$/ ) );#make sure the mail is not only reasonable looking, but safe to work with too
- return 'Email too long' if length $newmail > 255;
- return 'An account for this email address already exists' if( $tables->hasEmail( $newmail ) );
- return ( undef, $newmail );
-}
-
-sub registerSubmit( $$$ ) {#A registration form has been submited
- my( $req, $args, $tables ) = @_;
- my( $data, $error ) = getForm( {
- 'email' => sub {
- return emailCheck( shift, $tables );
- }
- }, [] );
- return genRegisterForm( $req, $args, $error, $data ) if( defined $error );
- my $site = $req->hostname();
- my $url = 'https://'.$req->hostname().setAddrPrefix( $req->uri(), 'mods' );
- sendMail( $data->{'email'}, 'Confirm registration', "Someone, probably you, requested registration of this address\n".
- "for the $site site. If it wasn't you, please ignore this email message.\n".
- "\nOtherwise, please continue by filling in the form at this address:".
- "\n".$url.'?action=register-confirm?email='.$data->{'email'}.'?confirm='.emailConfirm( $data->{'email'} )."\n".
- "\nThank you\n".
- "\n(This is an autogenerated email, do not respond to it)" );
- genHtmlHead( $req, 'Registration email sent', undef );
- print '<h1>Register email sent</h1>
- <p>
- An email containing further information has been sent to you.
- Please follow these instruction to finish the registration process.';
- genHtmlTail();
- return OK;
-}
-
-sub genConfirmForm( $$$$ ) {
- my( $req, $args, $error, $values ) = @_;
- genHtmlHead( $req, 'Confirm registration', undef );
- print '<h1>Confirm registration</h1>';
- print '<div class="error">'.$error.'</div>' if( defined $error );
- print '<p>Email address: '.encode( $values->{'email'} );
- print '<form name="register-confirm" id="register-confirm" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=register-confirm">';
- print '<div class="hidden"><p><input type="hidden" value="'.encode( $values->{'email'} ).'" name="email"><input type="hidden" value="'.encode( $values->{'confirm'} ).'" name="confirm"></div>';
- print '<table>';
- genForm( [ [ 'Login (Optional):', 'text', 'login', 'maxlength="50"' ],
- [ 'Password:', 'password', 'password' ],
- [ 'Confirm password:', 'password', 'confirm_password' ],
- [ '', 'submit', 'register', 'value=Register' ] ], $values );
- print '</table></form>';
- genHtmlTail();
- return OK;
-}
-
-sub usedAddress( $ ) {
- my( $req ) = @_;
- genHtmlHead( $req, 'Used address', undef );
- print '<h1>Used address</h1>
- <div class="error">
- <p>
- An account for this address is already registered.
- Please, start again with <a href="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=register">requesting a registration email</a> or <a href="'.setAddrPrefix( $req->uri(), 'mods' ).'?action=login">log in</a>.
- </div>';
- genHtmlTail();
- return 0;
-}
-
-sub checkRegHash( $$$$ ) {
- my( $req, $tables, $email, $hash ) = @_;
- if( ! checkConfirmHash( $email, $hash ) ) {
- genHtmlHead( $req, 'Invalid registration request', undef );
- print '<h1>Invalid registration request</h1>
- <div class="error">
- <p>
- This registration request is invalid.
- Are you sure you got it from the registration email?
- </div>';
- genHtmlTail();
- return 0;
- } elsif( $tables->hasEmail( $email ) ) {
- return usedAddress( $req );
- } else {
- return 1;
- }
-}
-
-sub confirmForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
- if( ! checkRegHash( $req, $tables, $args->{'email'}, $args->{'confirm'} ) ) {
- return OK;
- } else {
- return genConfirmForm( $req, $args, undef, $args );
- }
-}
-
-sub passLenCheck( $ ) {
- my( $pass ) = @_;
- return ( ( length $pass ) >= 4 ) ? undef : 'Password must have at least 4 characters';
-}
-
-sub passSameCheck( $ ) {
- my( $data ) = @_;
- return ( ( ( defined $data->{'password'} ) != ( defined $data->{'confirm_password'} ) ) || ( ( defined $data->{'password'} ) && ( $data->{'password'} ne $data->{'confirm_password'} ) ) ) ? 'Passwords do not match' : undef;
-}
-
-sub confirmSubmit( $$$ ) {
- my( $req, $args, $tables ) = @_;
- my( $data, $error ) = getForm( {
- 'email' => sub {
- return emailCheck( shift, $tables );
- },
- 'confirm' => undef,
- 'login' => sub {
- return loginCheck( shift, $tables );
- },
- 'password' => \&passLenCheck,
- 'confirm_password' => undef }, [ \&passSameCheck ] );
- return OK if( ! checkRegHash( $req, $tables, $data->{'email'}, $data->{'confirm'} ) );#Not much info, but this is an attack anyway
- return genConfirmForm( $req, $args, $error, $data ) if( defined $error );
- unless( addUser( $tables, $data->{'login'}, $data->{'email'}, $data->{'password'} ) ) {
- usedAddress( $req );
- return OK;
- }
- genHtmlHead( $req, 'Registered', undef );
- print '<h1>Registered</h1>
- <p>
- You are now registered.
- You can continue by <a href="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=login">logging in</a> or continue <a href="http://'.$req->hostname().setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args ).'?action=list">anonymously</a>.';
- genHtmlTail();
- return OK;
-}
-
-sub genLoginForm( $$$$ ) {
- my( $req, $args, $error, $values ) = @_;
- $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'cookie-test', -value => 1 ) );
- genHtmlHead( $req, 'Login', undef );
- print '<h1>Login</h1>';
- my $addr = PciIds::Address::new( $req->uri() );
- genCustomMenu( $addr, $args, [ [ 'Register', 'register' ], [ 'Reset password', 'respass' ] ] );
- print '<div class="error"><p>'.$error.'</div>' if( defined $error );
- print '<form name="login" id="login" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=login"><table>';
- genForm( [ [ 'Login name or email:', 'text', 'login', 'maxlength="255"' ],
- [ 'Password:', 'password', 'password' ],
- [ '', 'submit', 'login', 'value="Login"' ] ], $values );
- print '</table></form>';
- genHtmlTail();
- return OK;
-}
-
-sub loginForm( $$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless( $auth->{'ssl'} );
- return genLoginForm( $req, $args, undef, {} );
-}
-
-sub loginSubmit( $$$ ) {
- my( $req, $args, $tables ) = @_;
- my( $data, $error ) = getForm( {
- 'login' => undef,
- 'password' => undef
- }, [] );
- my $logged = 0;
- my $cookies = fetch CGI::Cookie;
- unless( $cookies->{'cookie-test'} ) {
- return genLoginForm( $req, $args, 'You need to enable cookies', $data );
- }
- my( $id, $passwd, $email, $last ) = $tables->getLogInfo( $data->{'login'} );
- if( defined $passwd && defined $data->{'password'} ) {
- my $salted = saltedPasswd( $email, $data->{'password'} );
- $logged = $salted eq $passwd;
- }
- if( $logged ) {
- $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => genAuthToken( $tables, $id, $req, undef ) ) );
- $args->{'action'} = ( defined $args->{'redirectaction'} ) ? $args->{'redirectaction'} : 'list';
- my $prefix = ( !defined( $args->{'action'} ) or ( $args->{'action'} eq '' ) or ( $args->{'action'} eq 'list' ) ) ? 'read' : 'mods';
- my $url = "http://".$req->hostname().setAddrPrefix( $req->uri(), $prefix ).buildExcept( 'redirectaction', $args );
- genHtmlHead( $req, 'Logged in', undef );
- print '<h1>Logged in</h1>';
- print '<div class="lastlog"><p>'.encode( $last ).'</div>' if( defined( $last ) );
- print "<p><a href='$url'>Continue here</a>";
- genHtmlTail();
- return OK;
- } else {
- return genLoginForm( $req, $args, 'Invalid login credetials', $data );
- }
-}
-
-sub logout( $$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => '0' ) );
- return PciIds::Html::List::list( $req, $args, $tables, {} );
-}
-
-sub checkLogin( $$ ) {
- my( $req, $tables ) = @_;
- my $cookies = fetch CGI::Cookie;
- my( $authed, $id, $regen, $rights, $error ) = checkAuthToken( $tables, $req, defined( $cookies->{'auth'} ) ? $cookies->{'auth'}->value : undef );
- if( $regen ) {
- $req->headers_out->add( 'Set-Cookie' => new CGI::Cookie( -name => 'auth', -value => genAuthToken( $tables, $id, $req, $rights ) ) );
- }
- my $hterror = $authed ? '' : '<div class="error"><p>'.$error.'</div>';
- return { 'authid' => $authed ? $id : undef, 'accrights' => $rights, 'logerror' => $hterror };
-}
-
-sub notLoggedComplaint( $$$ ) {
- my( $req, $args, $auth ) = @_;
- return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
- $args->{'redirectaction'} = $args->{'action'};
- return genLoginForm( $req, $args, 'This action requires you to be logged in', undef );
-}
-
-sub genResetPasswdForm( $$$$ ) {
- my( $req, $args, $error, $values ) = @_;
- genHtmlHead( $req, 'Reset password', undef );
- print "<h1>Reset password</h1>\n";
- print "<p>If you forgot your password (or didn't create one yet), you can reset it to a new value here.\n";
- print "Provide your email address here and further instructions will be sent to you.\n";
- print '<div class="error">'.$error.'</div>' if( defined $error );
- print '<form name="respass" id="respass" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=respass">
- <table>';
- genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
- [ '', 'submit', 'respass', 'value="Send"' ] ], $values );
- print '</table></form>';
- genHtmlTail();
- return OK;
-}
-
-sub resetPasswdForm( $$$$ ) {
- my( $req, $args ) = @_;
- return genResetPasswdForm( $req, $args, undef, {} );
-}
-
-sub resetPasswdFormSubmit( $$$ ) {
- my( $req, $args, $tables ) = @_;
- my( $data, $error ) = getForm( {
- 'email' => undef
- }, [] );
- my( $id, $login, $passwd ) = $tables->resetInfo( $data->{'email'} );
- if( defined( $id ) ) {
- $login = '' unless( defined( $login ) );
- my $site = $req->hostname();
- my $url = 'https://'.$req->hostname().setAddrPrefix( $req->uri(), 'mods' );
- my $hash = genResetHash( $id, $data->{'email'}, $login, $passwd );
- sendMail( $data->{'email'}, 'Reset password',
- "A request to reset password for the $site site was received for this address\n".
- "If you really wish to get a new password, visit this link:\n\n".
- $url.'?action=respass-confirm?email='.$data->{'email'}.'?confirm='.$hash."\n".
- "\n\nThank you\n".
- "\n(This is an autogenerated email, do not respond to it)" );
- genHtmlHead( $req, 'Reset password', undef );
- print "<h1>Reset password</h1>\n";
- print "<p>An email with information was sent to your address.\n";
- genHtmlTail();
- return OK;
- } else {
- $error = '<p>This email address is not registered. Check it for typos or <a href="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=register">register</a> it.';
- }
- return genResetPasswdForm( $req, $args, $error, $data ) if( defined( $error ) );
-}
-
-sub genResetPasswdConfigForm( $$$$$$ ) {
- my( $req, $args, $error, $values, $email, $hash ) = @_;
- genHtmlHead( $req, 'Reset password', undef );
- print "<h1>Reset password</h1>\n";
- print '<div class="error">'.$error.'</div>' if( defined $error );
- print "<p>You can enter new password here:\n";
- print '<form name="respass-confirm" id="respass-confirm" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=respass-confirm">
- <table>';
- genForm( [ [ 'Password:', 'password', 'password' ],
- [ 'Confirm password:', 'password', 'confirm_password' ],
- [ '', 'submit', 'respass', 'value="Send"' ] ], $values );
- print "</table>";
- print "<input type='hidden' name='email' value='".encode( $email )."'><input type='hidden' name='hash' value='".encode( $hash )."'>\n";
- print "</form>\n";
- genHtmlTail();
- return OK;
-}
-
-sub resetPasswdConfirmForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- my( $email, $hash ) = ( $args->{'email'}, $args->{'confirm'} );
- my( $id, $login, $passwd ) = $tables->resetInfo( $email );
- my $myHash;
- return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
- $myHash = genResetHash( $id, $email, $login, $passwd ) if( defined( $id ) );
- if( defined( $myHash ) && ( $myHash eq $hash ) ) {#Ok, it is his mail and he asked
- return genResetPasswdConfigForm( $req, $args, undef, {}, $email, $hash );
- } else {
- genHtmlHead( $req, 'Reset password', undef );
- print "<h1>Reset password</h1>\n";
- print "<p>Provided link is not valid. Did you use it already?\n";
- print "<p>You can get a <a href='".$req->uri()."?action=respass'>new one</a>.\n";
- genHtmlTail();
- return OK;
- }
-}
-
-sub resetPasswdConfirmFormSubmit( $$$ ) {
- my( $req, $args, $tables ) = @_;
- my( $data, $error ) = getForm( {
- 'password' => \&passLenCheck,
- 'confirm_password' => undef,
- 'email' => undef,
- 'hash' => undef
- }, [ \&passSameCheck ] );
- my( $email, $hash ) = ( $data->{'email'}, $args->{'confirm'} );
- if( defined( $error ) ) {
- return genResetPasswdConfigForm( $req, $args, $error, $data, $email, $hash );
- } else {
- my( $id, $login, $passwd ) = $tables->resetInfo( $email );
- my $myHash;
- $myHash = genResetHash( $id, $email, $login, $passwd ) if( defined( $id ) );
- if( defined( $myHash ) && ( $myHash eq $hash ) ) {
- changePasswd( $tables, $id, $data->{'password'}, $email );
- genHtmlHead( $req, 'Reset password', undef );
- print "<h1>Reset password</h1>\n";
- print "<p>Your password was successfuly changed. You can <a href='".$req->uri()."?action=login'>log in</a>.\n";
- genHtmlTail();
- return OK;
- } else {
- return genResetPasswdConfigForm( $req, $args, $error, $data, $email, $hash );
- }
- }
-}
-
-sub genProfileForm( $$$$$ ) {
- my( $req, $args, $error, $data, $info ) = @_;
- genHtmlHead( $req, 'User profile', undef );
- delete $data->{'current_password'};
- delete $data->{'confirm_password'};
- delete $data->{'password'};
- print "<h1>User profile</h1>\n";
- print '<div class="error"><p>'.$error.'</div>' if defined $error;
- print "<div class='info'><p>$info</div>\n" if defined $info;
- print '<form name="profile" id="profile" method="POST" action="'.setAddrPrefix( $req->uri(), 'mods' ).buildExcept( 'action', $args ).'?action=profile"><table>';
- genForm( [ [ 'Email:', 'text', 'email', 'maxlength="255"' ],
- [ 'Login:', 'text', 'login', 'maxlength="50"' ],
- [ 'Xmpp:', 'text', 'xmpp', 'maxlength="255"' ],
- [ 'New password:', 'password', 'password' ],
- [ 'Confirm password:', 'password', 'confirm_password' ],
- [ 'Current password:', 'password', 'current_password' ],
- [ 'Email batch time (min):', 'text', 'email_time', 'maxlength="10"' ],
- [ 'Xmpp batch time (min):', 'text', 'xmpp_time', 'maxlength="10"' ],
- [ '', 'submit', 'profile', 'value="Submit"' ] ], $data );
- print '</table></form>';
- print "<p><a class='navigation' href='http://".$req->hostname().setAddrPrefix( $req->uri(), 'read' ).buildExcept( 'action', $args )."?action=list'>Back to browsing</a>\n";
- genHtmlTail();
- return OK;
-}
-
-sub profileForm( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
- return HTTPRedirect( $req, 'https://'.$req->hostname().$req->uri().buildArgs( $args ) ) unless $auth->{'ssl'};
- return genProfileForm( $req, $args, undef, $tables->profileData( $auth->{'authid'} ), undef );
-}
-
-sub checkNum( $$ ) {
- my( $value, $name ) = @_;
- return ( "$name has invalid number format", '0' ) unless ( $value =~ /\d+/ );
- return undef;
-}
-
-sub profileFormSubmit( $$$$ ) {
- my( $req, $args, $tables, $auth ) = @_;
- return notLoggedComplaint( $req, $args, $auth ) unless defined $auth->{'authid'};
- my $oldData = $tables->profileData( $auth->{'authid'} );
- my( $data, $error ) = getForm( {
- 'email' => sub {
- my $email = shift;
- return undef if ( defined $email ) && ( $email eq $oldData->{'email'} );
- return emailCheck( $email, $tables );
- },
- 'login' => sub {
- my $login = shift;
- $login = undef if ( defined $login ) && ( $login eq '' );
- return undef if ( defined $login ) && ( defined $oldData->{'login'} ) && ( $oldData->{'login'} eq $login );
- return ( undef, $login ) if ( !defined $login ) && ( !defined $oldData->{'login'} );
- return loginCheck( $login, $tables );
- },
- 'xmpp' => sub {
- my $xmpp = shift;
- return ( undef, undef ) if ( !defined $xmpp ) || ( $xmpp eq '' );
- return "Xmpp address limit is 255" if length $xmpp > 255;
- return "Invalid Xmpp address" unless $xmpp =~ /^([^'"\@<>\/]+\@)?[^\@'"<>\/]+(\/.*)?/;
- return undef;
- },
- 'password' => sub {
- my $passwd = shift;
- $passwd = undef if ( defined $passwd ) && ( $passwd eq '' );
- return ( undef, undef ) unless defined $passwd;
- return passLenCheck( $passwd );
- },
- 'confirm_password' => undef,
- 'current_password' => undef,
- 'email_time' => sub {
- return checkNum( shift, "Email batch time" );
- },
- 'xmpp_time' => sub {
- return checkNum( shift, "Xmpp batch time" );
- }
- }, [ sub {
- my $data = shift;
- return undef unless defined $data->{'password'};
- return passSameCheck( $data );
- }, sub {
- my $data = shift;
- my $change = 0;
- $change = 1 if $data->{'email'} ne $oldData->{'email'};
- $change = 1 if ( ( ( defined $data->{'login'} ) != ( defined $oldData->{'login'} ) ) || ( ( defined $data->{'login'} ) && ( defined $oldData->{'login'} ) && ( $data->{'login'} ne $oldData->{'login'} ) ) );
- $change = 1 if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
- return undef unless $change;
- my $logged = 0;
- my( $id, $passwd, $email, $last ) = $tables->getLogInfo( $oldData->{'email'} );
- if( defined $passwd && defined $data->{'current_password'} ) {
- my $salted = saltedPasswd( $email, $data->{'current_password'} );
- $logged = ( $salted eq $passwd ) && ( $id == $auth->{'authid'} );
- }
- return "You need to provide correct current password to change email, login or password" unless $logged;
- return undef;
- } ] );
- return genProfileForm( $req, $args, $error, $data, undef ) if defined $error;
- pushProfile( $tables, $auth->{'authid'}, $oldData, $data );
- return genProfileForm( $req, $args, undef, $data, "Profile updated." );
-}
-
-1;
+++ /dev/null
-package PciIds::Html::Util;
-use strict;
-use warnings;
-use HTML::Entities;
-use base 'Exporter';
-use PciIds::Users;
-use Apache2::Const qw(:common :http);
-use APR::Table;
-
-our @EXPORT = qw(&genHtmlHead &htmlDiv &genHtmlTail &genTableHead &genTableTail &parseArgs &buildExcept &buildArgs &genMenu &genCustomMenu &encode &setAddrPrefix &HTTPRedirect);
-
-sub encode( $ ) {
- return encode_entities( shift, "\"'&<>" );
-}
-
-sub genHtmlHead( $$$ ) {
- my( $req, $caption, $metas ) = @_;
- $req->content_type( 'text/html; charset=utf-8' );
- $req->headers_out->add( 'Cache-control' => 'no-cache' );
- print '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN" "http://www.w3.org/TR/html4/strict.dtd">'."\n";
- print '<html lang="en"><head><title>'.encode( $caption )."</title>\n";
- print "<link rel='stylesheet' type='text/css' media='screen' href='/static/screen.css'>\n";
- print "<link rel='stylesheet' type='text/css' media='print' href='/static/print.css'>\n";
- print $metas if( defined( $metas ) );
- print "</head><body>\n";
-}
-
-sub genHtmlTail() {
- print '</body></html>';
-}
-
-sub htmlDiv( $$ ) {
- my( $class, $text ) = @_;
- return '<div class="'.$class.'">'.$text.'</div>';
-}
-
-sub item( $$$ ) {
- my( $url, $label, $action ) = @_;
- print " <li><a href='".$url.$action."'>$label</a>\n";
-}
-
-sub genCustomMenu( $$$ ) {
- my( $address, $args, $list ) = @_;
- my $url = '/'.$address->get().buildExcept( 'action', $args ).'?action=';
- print "<div class='menu'>\n<ul>\n";
- foreach( @{$list} ) {
- my( $label, $action ) = @{$_};
- my $prefix = '/mods';
- $prefix = '/read' if( !defined( $action ) or ( $action eq 'list' ) or ( $action eq '' ) );
- item( $prefix.$url, $label, $action );
- }
- print "</ul></div>\n";
-}
-
-sub genMenu( $$$ ) {
- my( $address, $args, $auth ) = @_;
- my @list;
- if( defined( $auth->{'authid'} ) ) {
- push @list, [ 'Log out', 'logout' ];
- } else {
- push @list, [ 'Log in', 'login' ];
- }
- push @list, [ 'Add item', 'newitem' ] if( $address->canAddItem() );
- push @list, [ 'Discuss', 'newcomment' ] if( $address->canAddComment() );
- push @list, [ 'Administrate', 'admin' ] if( hasRight( $auth->{'accrights'}, 'validate' ) );
- push @list, [ 'Profile', 'profile' ] if defined $auth->{'authid'};
- push @list, [ 'Notifications', 'notifications' ] if defined $auth->{'authid'};
- genCustomMenu( $address, $args, \@list );
-}
-
-sub genTableHead( $$ ) {
- my( $class, $captions ) = @_;
- print '<table class="'.$class.'"><tr>';
- foreach( @{$captions} ) {
- print '<th>'.$_;
- }
- print '</tr>';
-}
-
-sub genTableTail() {
- print '</table>';
-}
-
-sub parseArgs( $ ) {
- my %result;
- foreach( split /\?/, shift ) {
- next unless( /=/ );
- my( $name, $value ) = /^([^=]+)=(.*)$/;
- $result{$name} = $value;
- }
- return \%result;
-}
-
-sub buildArgs( $ ) {
- my( $args ) = @_;
- my $result = '';
- $result .= "?$_=".$args->{$_} foreach( keys %{$args} );
- return $result;
-}
-
-sub buildExcept( $$ ) {
- my( $except, $args ) = @_;
- my %backup = %{$args};
- delete $backup{$except};
- return buildArgs( \%backup );
-}
-
-sub setAddrPrefix( $$ ) {
- my( $addr, $prefix ) = @_;
- $addr =~ s/\/(mods|read|static)//;
- return "/$prefix$addr";
-}
-
-sub HTTPRedirect( $$ ) {
- my( $req, $link ) = @_;
- $req->headers_out->add( 'Location' => $link );
- return HTTP_SEE_OTHER;
-}
-
-1;
+++ /dev/null
-package PciIds::Log;
-use strict;
-use warnings;
-use base 'Exporter';
-use PciIds::Config;
-
-our @EXPORT = qw(&flog &tlog &logEscape &tulog);
-
-checkConf( [ 'logfile' ] );
-
-sub flog( $ ) {
- my( $text ) = @_;
- open LOG, '>>'.$config{'logfile'} or die "Could not open log file\n";
- print LOG "$text\n";
- close LOG;
-}
-
-sub tlog( $ ) {
- my( $text ) = @_;
- my $time = time;
- flog( "$time: $text" );
-}
-
-sub tulog( $$ ) {
- my( $user, $text ) = @_;
- tlog( "User $user: $text" );
-}
-
-sub logEscape( $ ) {
- my( $text ) = @_;
- return "''" unless defined $text;
- $text =~ s/(['"\\])/\\$1/g;
- return "'$text'";
-}
-
-1;
+++ /dev/null
-package PciIds::Notifications;
-use strict;
-use warnings;
-use PciIds::Address;
-use PciIds::Config;
-use PciIds::Email;
-use PciIds::Xmpp;
-use base 'Exporter';
-
-our @EXPORT = qw(¬ify &sendNotifs &flushNotifs);
-
-sub notify( $$$$$ ) {
- my( $tables, $location, $comment, $priority, $reason ) = @_;
- $tables->pushNotifications( $location, $comment, $priority, $reason );
-}
-
-sub sendNotif( $$$ ) {
- my( $address, $message, $sendFun ) = @_;
- return unless defined $address;
- &{$sendFun}(
- $address,
- "Item change notifications for $config{hostname}",
- "$message\nThis is automatic notification message, do not respond to it.\nYou can change your notifications at http://$config{hostname}/mods/PC/?action=notifications\n" );
-}
-
-sub sendOut( $$ ) {
- my( $notifs, $sendFun ) = @_;
- my( $last_address, $last_user );
- my $message = '';
- foreach( @{$notifs} ) {
- my( $user, $address, $reason, $text, $newname, $newdesc, $time, $author, $location, $name, $desc ) = @{$_};
- if( ( !defined $last_user ) || ( $last_user != $user ) ) {
- sendNotif( $last_address, $message, $sendFun );
- $last_address = $address;
- $last_user = $user;
- $message = '';
- }
- my $note;
- my $addr = PciIds::Address::new( $location );
- if( $reason == 0 ) {
- $note = "New item was created.\n Id: ".$addr->pretty()."\n Name: $newname\n";
- $note .= " Description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
- $note .= " Comment text: $text\n" if( defined $text && ( $text ne '' ) );
- $note .= " Author: $author\n" if( defined $author && ( $author ne '' ) );
- $note .= " Time: $time\n";
- $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
- } elsif( $reason == 1 ) {
- $note = "New comment created.\n Item:\n";
- $note .= " Id: ".$addr->pretty()."\n";
- $note .= " Name: $name\n" if( defined $name && ( $name ne '' ) && ( $name ne $newname ) );
- $note .= " Description: $desc\n" if( defined $desc && ( $desc ne '' ) && ( $desc ne $newdesc ) );
- $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
- $note .= " Comment:\n";
- $note .= " Proposed name: $newname\n" if( defined $newname && ( $newname ne '' ) );
- $note .= " Proposed description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
- $note .= " Text: $text\n" if( defined $text && ( $text ne '' ) );
- $note .= " Author: $author\n" if( defined $author && ( $author ne '' ) );
- $note .= " Time: $time\n";
- } elsif( $reason == 2 ) {
- $note = "Item name validated.\n Id:".$addr->pretty()."\n";
- $note .= " Name: $newname\n";
- $note .= " Description: $newdesc\n" if( defined $newdesc && ( $newdesc ne '' ) );
- $note .= " Comment text: $text\n" if( defined $text && ( $text ne '' ) );
- $note .= " Address: http://".$config{'hostname'}."/read/".$addr->get()."\n";
- }
- $message .= "\n" unless $message eq '';
- $message .= $note;
- }
- sendNotif( $last_address, $message, $sendFun );
-}
-
-sub sendNotifs( $ ) {
- my( $tables ) = @_;
- my $time = $tables->time();
- sendOut( $tables->mailNotifs( $time ), \&PciIds::Email::sendMail );
- sendOut( $tables->xmppNotifs( $time ), \&PciIds::Xmpp::sendXmpp );
- $tables->dropNotifs( $time );
-}
-
-checkConf( [ 'hostname' ] );
-
-1;
+++ /dev/null
-package PciIds::Users;
-use strict;
-use warnings;
-use base 'Exporter';
-use PciIds::Db;
-use DBI;
-use PciIds::Config;
-use Digest::MD5 qw(md5_base64 md5_hex);#TODO Some better algorithm?
-use HTML::Entities;
-use Startup;
-use PciIds::Log;
-use Apache2::Connection;
-
-my( %privnames, %privnums );
-
-our @EXPORT = qw(&addUser &emailConfirm &checkConfirmHash &saltedPasswd &genAuthToken &checkAuthToken &hasRight &getRightDefs &genResetHash &changePasswd &pushProfile);
-
-sub saltedPasswd( $$ ) {
- my( $email, $passwd ) = @_;
- my $salt = $config{'passwdsalt'};
- return md5_base64( "$email:$passwd:$salt" );
-}
-
-sub genResetHash( $$$$ ) {
- my( $id, $email, $login, $passwd ) = @_;
- my $salt = $config{'regmailsalt'};
- return md5_hex( "$id:$email:$login:$passwd:$salt" );
-}
-
-sub emailConfirm( $ ) {
- my( $email ) = @_;
- my $salt = $config{'regmailsalt'};
- return md5_hex( $email.$salt );
-}
-
-sub checkConfirmHash( $$ ) {
- my( $email, $hash ) = @_;
- return 0 unless( ( defined $email ) && ( defined $hash ) );
- my( $expected ) = emailConfirm( $email );
- return ( $expected eq $hash );
-}
-
-sub addUser( $$$$ ) {
- my( $tables, $name, $email, $passwd ) = @_;
- my $salted = saltedPasswd( $email, $passwd );
- tlog( "Creating user $email" . ( ( defined $name ) ? " - $name" : '' ) );
- my $id = $tables->addUser( $name, $email, $salted );
- tlog( "User ($email) id: $id" );
- return $id;
-}
-
-sub changePasswd( $$$$ ) {
- my( $tables, $id, $passwd, $email ) = @_;
- my $salted = saltedPasswd( $email, $passwd );
- $tables->changePasswd( $id, $salted );
-}
-
-sub genAuthToken( $$$$ ) {
- my( $tables, $id, $req, $rights ) = @_;
- unless( defined $rights ) {#Just logged in
- my $from = $req->connection()->remote_ip();
- $tables->setLastLog( $id, $from );
- $rights = $tables->rights( $id );
- }
- my $haveRights = scalar @{$rights};
- my $time = time;
- my $ip = $req->connection()->remote_ip();
- return "$id:$haveRights:$time:".md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
-}
-
-sub checkAuthToken( $$$ ) {
- my( $tables, $req, $token ) = @_;
- my( $id, $haveRights, $time, $hex ) = defined( $token ) ? split( /:/, $token ) : ();
- return ( 0, 0, 0, [], "Not logged in" ) unless( defined $hex );
- my $ip = $req->connection()->remote_ip();
- my $expected = md5_hex( "$id:$time:$ip:".$config{'authsalt'} );
- my $actTime = time;
- my $tokOk = ( $expected eq $hex );
- my $authed = ( $tokOk && ( $time + $config{'authtime'} > $actTime ) );
- my $regen = $authed && ( $time + $config{'regenauthtime'} < $actTime );
- my $rights = [];
- if( $haveRights ) {
- foreach( @{$tables->rights( $id )} ) {
- my %r;
- ( $r{'id'} ) = @{$_};
- $r{'name'} = $privnames{$r{'id'}};
- push @{$rights}, \%r;
- }
- }
- return ( $authed, $id, $regen, $rights, $authed ? undef : ( $tokOk ? "Login timed out" : "Not logged in x" ) );
-}
-
-sub hasRight( $$ ) {
- my( $rights, $name ) = @_;
- foreach( @{$rights} ) {
- return 1 if( $_->{'name'} eq $name );
- }
- return 0;
-}
-
-sub getRightDefs() {
- return ( \%privnums, \%privnames );
-}
-
-sub pushProfile( $$$$ ) {
- my( $tables, $id, $oldData, $data ) = @_;
- my( $email, $passwd ) = ( $data->{'email'}, $data->{'current_password'} );
- if( ( defined $passwd ) && ( $passwd ne '' ) ) {
- my $salted = saltedPasswd( $email, $passwd );
- $tables->setEmail( $id, $email, $salted );
- }
- $data->{'login'} = undef if ( defined $data->{'login'} ) && ( $data->{'login'} eq '' );
- $data->{'xmpp'} = undef if ( defined $data->{'xmpp'} ) && ( $data->{'xmpp'} eq '' );
- $tables->pushProfile( $id, $data->{'login'}, $data->{'xmpp'}, $data->{'email_time'}, $data->{'xmpp_time'} );
- changePasswd( $tables, $id, $data->{'password'}, $email ) if ( defined $data->{'password'} ) && ( $data->{'password'} ne '' );
-}
-
-checkConf( [ 'passwdsalt', 'regmailsalt', 'authsalt' ] );
-defConf( { 'authtime' => 2100, 'regenauthtime' => 300 } );
-
-open PRIVS, $directory."/rights" or die "Could not open privilege definitions\n";
-foreach( <PRIVS> ) {
- my( $num, $name ) = /^(\d+)\s+(.*)$/ or die "Invalid syntax in privileges\n";
- $privnames{$num} = $name;
- $privnums{$name} = $num;
-}
-close PRIVS;
-
-1;
+++ /dev/null
-package PciIds::Xmpp;
-use strict;
-use warnings;
-use PciIds::Config;
-use base 'Exporter';
-
-our @EXPORT = qw(&sendXmpp &flushXmpp);
-
-my @pending;
-
-sub sendXmpp( $$$ ) {
- my( $to, $subject, $body ) = @_;
- push @pending, [ $to, $subject, $body ];
-}
-
-sub flushXmpp() {
- return unless @pending;
- open JELNET, "|$config{xmpp_pipe} > /dev/null" or die "Could not start XMPP sender\n";
- foreach( @pending ) {
- my( $to, $subject, $body ) = @{$_};
- $subject =~ s/&/&/g;
- $subject =~ s/'/'/g;
- $subject =~ s/"/"/g;
- $body =~ s/&/&/g;
- $body =~ s/</</g;
- $body =~ s/>/>/g;
- print JELNET "<message to='$to'><subject>$subject</subject><body>$body</body></message>";
- }
- close JELNET;
-}
-
-checkConf( [ "xmpp_pipe" ] );
-
-1;
+++ /dev/null
-package Startup;
-use strict;
-use warnings;
-use base 'Exporter';
-
-#Where are data?
-our $directory = '/home/vorner/skola/cvika/internet/impl';
-our @EXPORT=qw($directory);
-
-#Where are the modules?
-use lib ( '/home/vorner/skola/cvika/internet/impl' );
-
-1;
+++ /dev/null
-db = pciids
-dbuser = pciids
-dbpasswd = 1234
-passwdsalt = 1234
-regmailsalt = 1234
-authsalt = 1234
-from_addr = vorner+pciids@ucw.cz
-sendmail = /home/vorner/bin/sendmail-apache
-logfile = /home/vorner/skola/cvika/internet/impl/pciids.log
-hostname = localhost
-xmpp_pipe = /home/vorner/bin/xmpp_pipe
+++ /dev/null
-• Can use mod_perl?
-
-• Deleting users
- - Allow deleting?
- - What to do with history, when user deleted?
-
-• Importing data
- - What to do, when it changes a name/comment?
- . if it has main article
- . if it doesn't have main article
+++ /dev/null
-1 validate
-2 listUsers
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use DBI;
-
-my $dbh = connectDb();
-$dbh->prepare( 'DELETE FROM locations' )->execute();
-$dbh->prepare( 'DELETE FROM history' )->execute();
-$dbh->commit();
-$dbh->disconnect();
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use PciIds::DBQAny;
-
-my $db = PciIds::DBQAny::new( connectDb(), {
- 'list' => 'SELECT id, name, description FROM locations WHERE name IS NOT NULL ORDER BY id'
-} );
-
-foreach( @{$db->query( 'list', [] )} ) {
- my( $id, $name, $description ) = @{$_};
- $_ = $id;
- my $prefix = ( /^PC/ ) ? '' : 'C ';
- s/^P.\///;
- s/[^\/]//g;
- s/\//\t/g;
- my $tabs = $_;
- $id =~ s/.*\///;
- print "$tabs$prefix$id $name\n";
- if( defined( $description ) && ( $description ne '' ) ) {
- chomp $description;
- $description =~ s/\n/\n$tabs#/g;
- print "$tabs#$description\n";
- }
-}
-
-$db->commit();
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use DBI;
-
-my $dbh = connectDb();
-my $query = $dbh->prepare( "INSERT INTO locations (id, name, description, parent) VALUES(?, ?, ?, ?);" ) or die "Could not create the query (".DBI->errstr.")\n";
-my $comment = $dbh->prepare( "INSERT INTO history (location, nodename, nodedescription, seen) VALUES(?, ?, ?, '1')" ) or die "Could not create query (".DBI->errstr.")\n";
-my $update = $dbh->prepare( "UPDATE locations SET maincomment = ? WHERE id = ?" ) or die "Could not create query (".DBI->errstr.")\n";
-my( $vendor, $type, $sub, $description, $name );
-
-$query->execute( "PC", undef, undef, undef ) or die "Could not add toplevel node\n";
-$query->execute( "PD", undef, undef, undef ) or die "Could not add toplevel node\n";
-
-sub submit( $ ) {
- my( $id ) = @_;
- my $parent = $id;
- $parent =~ s/\/[^\/]+$//;
- $query->execute( $id, $name, $description, $parent );
- $comment->execute( $id, $name, $description );
- my $com = $dbh->last_insert_id( undef, undef, undef, undef );
- $update->execute( $com, $id );
- undef $description;
-}
-
-print "Filling database from id file\n";
-
-foreach( <> ) {
- chomp;
- if( s/^\s*#\s*// ) {
- $description = $_;
- } elsif( /^\s*$/ ) {
- undef $description;
- } elsif( /^\t\t/ ) {
- if( $vendor =~ /^PC/ ) {
- ( $sub, $name ) = /^\s*([0-9a-fA-F]+\s[0-9a-fA-F]+)\s+(.*)$/;
- $sub =~ s/\s+//g;
- } else {
- ( $sub, $name ) = /^\s*([0-9a-fA-F]+)\s+(.*)$/;
- }
- submit( $vendor.'/'.$type.'/'.$sub );
- } elsif( /^\t/ ) {
- ( $type, $name ) = /^\s*([0-9a-fA-F]+)\s+(.*)$/;
- submit( $vendor.'/'.$type );
- } elsif( /^C\s/ ) {
- ( $vendor, $name ) = /^C\s+([0-9a-fA-F]+)\s+(.*)$/;
- $vendor = 'PD/'.$vendor;
- submit( $vendor );
- } elsif( /^[0-9a-fA-F]/ ) {
- ( $vendor, $name ) = /([0-9a-fA-F]+)\s+(.*)$/;
- $vendor = 'PC/'.$vendor;
- submit( $vendor );
- } else {
- die "Um what?? $_\n";
- }
-}
-$dbh->commit();
-$dbh->disconnect;
+++ /dev/null
-#!/usr/bin/perl
-use strict;
-BEGIN {
- unshift @INC, ".";
-};
-use PciIds::Db;
-
-my %tracked;
-
-sub translateLoc( $ ) {
- my $loc = shift;
- $loc =~ s/(.{8})(.+)/$1\/$2/;
- $loc =~ s/(.{4})(.+)/$1\/$2/;
- return "PC/$loc";
-}
-
-my $dbh = connectDb();
-my $clearHist = $dbh->prepare( 'DELETE FROM history WHERE location = ?' );
-my %coms;
-my $com = $dbh->prepare( 'INSERT INTO history (owner, location, time, nodename, nodedescription) VALUES (?, ?, FROM_UNIXTIME(?), ?, ?)' );
-my $user = $dbh->prepare( 'SELECT id FROM users WHERE email = ?' );
-my $delHis = $dbh->prepare( 'DELETE FROM history WHERE id = ?' );
-my $markMain = $dbh->prepare( 'UPDATE locations SET
- maincomment = ?,
- name = ( SELECT nodename FROM history WHERE id = ? ),
- description = ( SELECT nodedescription FROM history WHERE id = ? )
- WHERE
- id = ?' );
-my $markSeen = $dbh->prepare( "UPDATE history SET seen = '1' WHERE id = ?" );
-
-sub getUser( $ ) {
- $user->execute( shift );
- if( my( $id ) = $user->fetchrow_array ) {
- return $id;
- } else {
- return undef;
- }
-}
-
-my $accept = 0;
-my $reject = 0;
-my $del = 0;
-my $appr = 0;
-
-print "Parsing and importing log\n";
-
-foreach( <> ) {
- my( $time, $who, $ip, $command, $id, $location, $name, $description, $email );
- if( ( $time, $who, $ip, $command, $id, $location, $name, $description, $email ) = /^(\d+) (\S+) ([0-9.]+) (Create|Batch submit:) (\d+) ([0-9a-f]+) '(.*)(?<!\\)' '(.*)(?<!\\)' '(.*)(?<!\\)'/ ) {
- my $translated = translateLoc( $location );
- unless( $tracked{$location} ) {#From now on, it is restored from the log
- $tracked{$location} = 1;
- $clearHist->execute( $translated );
- }
- $name =~ s/\\(.)/$1/g;
- $description =~ s/\\(.)/$1/g;
- $name = undef if( $name eq '' );
- $description = undef if( $description eq '' );
- eval {#If the item is not here at all, it was deleted -> no need to add it here
- $com->execute( getUser( $email ), $translated, $time, $name, $description );
- $coms{$id} = $dbh->last_insert_id( undef, undef, undef, undef );
- $accept ++;
- };
- if( $@ ) {
- $reject ++;
- }
- } elsif( ( $time, $who, $ip, $command, $id, $location, $description, $email ) = /^(\d+) (\S+) ([0-9.]+) (Approve|Delete|Overriden) (\d+) ([0-9a-f]+) '(.*)(?<!\\)' '(.*)(?<!\\)'/ ) {
- next unless( defined( $coms{$id} ) );#This one not tracked yet
- if( $command eq 'Approve' ) {
- my $i = $coms{$id};
- $markMain->execute( $i, $i, $i, translateLoc( $location ) );
- $markSeen->execute( $i );
- $appr ++;
- } elsif( $command eq 'Delete' ) {
- $delHis->execute( $coms{$id} );
- $del ++;
- } else {
- $markSeen->execute( $coms{$id} );
- }
- } else {
- print "Unparsed line: $_";
- }
-}
-
-$dbh->commit();
-$dbh->disconnect();
+++ /dev/null
-./scripts/initdb.pl
-./scripts/feeddb.pl pci.ids
-./scripts/transfer.pl pciidsold
-./scripts/importlog.pl iii.log
-echo 'Database is prepared, but it does not contain admins. Add them manually, please.'
-echo 'Just register like ordinary user and run ./scripts/rights.pl + username validate'
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Config;
-use PciIds::Db;
-use DBI;
-
-my @lines;
-my $tablename;
-
-defConf( { "dbcharset" => "UTF8", "dbtype" => "InnoDB" } );
-
-my %replaces = (
- "CHARSET" => "CHARSET ".$config{"dbcharset"}
-);
-
-sub createTable( $ ) {
- die "Invalid table definition\n" unless( defined( $tablename ) && @lines );
- my $nt = $_[ 0 ]->prepare( "CREATE TABLE ".$tablename." (".( join "\n", @lines ).") TYPE = $config{dbtype};" );
- $nt->execute();
- @lines = ();
- print "Created table $tablename\n";
- undef $tablename;
-}
-
-my $dbh = connectDb();
-open TABLES, "tables" or die "Could not open table definitions\n";
-foreach( <TABLES> ) {
- chomp;
- if( /^\s*$/ ) {
- createTable( $dbh );
- } elsif( s/^@// ) {
- $tablename = $_;
- } else {
- s/#.*//;
- s/<<([^<>]+)>>/$replaces{$1}/g;
- push @lines, $_;
- }
-}
-close TABLES;
-createTable( $dbh );
-$dbh->commit();
-$dbh->disconnect;
+++ /dev/null
-#!/usr/bin/perl
-# Mail robot for processing of PCI ID submissions
-# (c) 2001--2002 Martin Mares <mj@ucw.cz>
-# 2008 Michal Vaner <vorner@ucw.cz>
-
-use Mail::Header;
-use Getopt::Long;
-use IO::Handle;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use PciIds::Log;
-use PciIds::Notifications;
-use PciIds::DBQ;
-
-my $patch = 0;
-my $emulate = 0;
-my $debug = 0;
-my $original = "";
-my $author = "";
-GetOptions(
- 'patch!' => \$patch,
- 'emulate!' => \$emulate,
- 'debug!' => \$debug,
- 'orig=s' => \$original,
- 'author=s' => \$author
-) || die "Usage: mailbot [--patch] [--emulate] [--debug] [--orig <name>] [--author <mailaddr>]";
-
-my $reply = "";
-my $reply_plain = "";
-my $msgid = "";
-my $subject = "";
-my $tables = PciIds::DBQ::new( connectDb() );
-
-my $hasAuth = $tables->dbh()->prepare( 'SELECT id FROM users WHERE email = ?' );
-my $addAuth = $tables->dbh()->prepare( "INSERT INTO users (email, passwd) VALUES(?, '')" );
-my $hasItem = $tables->dbh()->prepare( "SELECT 1 FROM locations WHERE id = ?" );
-my $addItem = $tables->dbh()->prepare( "INSERT INTO locations (id, parent) VALUES (?, ?)" );
-my $addComment = $tables->dbh()->prepare( "INSERT INTO history (owner, location, text, nodename, nodedescription) VALUES (?, ?, ?, ?, ?)" );
-
-sub getAuthor( $ ) {
- my( $mail ) = @_;
- $hasAuth->execute( $mail );
- if( my( $id ) = $hasAuth->fetchrow_array ) {
- return $id;
- } else {
- tlog( "mailbot: Creating user $mail" );
- $addAuth->execute( $mail );
- my $nid = $dbh->last_insert_id( undef, undef, undef, undef );
- tlog( "mailbot: User ($mail) id: $nid" );
- return $nid;
- }
-}
-
-sub submitItem( $$$$$ ) {
- my( $id, $name, $description, $text, $author ) = @_;
- my $created;
- $id =~ s/(.{8})(.*)/$1\\$2/;
- $id =~ s/(.{4})(.*)/$1\\$2/;
- $id = "PC/$id";
- $hasItem->execute( $id );
- unless( $hasItem->fetchrow_array ) {
- tlog( "mailbot: Item created (empty) $id" );
- my $parent = $id;
- $parent =~ s/\/[^\/]*//;
- $addItem->execute( $id, $parent );
- $created = 1;
- }
- $addComment->execute( $author, $id, $text, $name, $description );
- my $hid = $tables->last();
- tlog( "mailbot: Comment created $hid $id ".logEscape( $name )." ".logEscape( $description )." ".logEscape( $text ) );
- notify( $tables, $id, $hid, $created ? 2 : 1, $created ? 0 : 1 );
-}
-
-if (!$patch) {
- $hdr = new Mail::Header;
- $hdr->modify(1);
- $hdr->mail_from(COERCE);
- $hdr->read(*STDIN{IO});
- $hdr->unfold();
- $mfrom = $hdr->get('Mail-From');
- chomp $mfrom;
- ($mfrom =~ /^MAILER-DAEMON@/i) && blackhole("From mailer daemon");
- $mfrom =~ s/ .*// or blackhole("Malformed envelope sender");
- ($reply = $hdr->get('Reply-To')) || ($reply = $hdr->get('From')) ||
- blackhole("Don't know who should I reply to");
- chomp $reply;
- if ($reply =~ /<(\S*)>/) {
- $reply_plain = $1;
- } elsif ($reply =~ /^\S+$/) {
- $reply_plain = $reply;
- } else {
- $reply_plain = $mfrom;
- }
- $reply_plain =~ tr/\n'"\\//d;
- $msgid = $hdr->get('Message-Id');
- chomp $msgid;
- my $subj = $hdr->get('Subject');
- chomp $subj;
- if ($subj =~ /^IDS: (.*)/) {
- $subject = $1;
- }
- $author = $reply_plain;
-}
-
-$tprefix = "tmp/mbot-$$";
-$home = "../..";
-mkdir("tmp", 0777);
-mkdir($tprefix, 0777) || error("Cannot create tmpdir");
-chdir($tprefix) || error("Cannot chdir to tmpdir");
-
-open(TEMP, ">patch") || error("Cannot create tmpfile");
-if ($debug || $reply eq "") {
- open(LOG, ">&STDOUT") || error ("Cannot create outfile");
-} else {
- open(LOG, ">log") || error ("Cannot create outfile");
- LOG->autoflush(1);
-}
-if ($reply) {
- print LOG "Got mail from $reply, will reply to $reply_plain.\n";
- print LOG "Scanning mail for patch.\n";
-} else {
- print LOG "Scanning STDIN for patch.\n";
-}
-while (<STDIN>) {
- while (/^--- /) {
- $l0 = $_;
- $_ = <STDIN>;
- if (/^\+\+\+ /) {
- print TEMP $l0;
- print TEMP $_;
- while (1) {
- $_ = <STDIN>;
- chomp;
- if (/^\s*$/ || !/^[ +\@-]/) {
- close TEMP;
- process();
- exit 0;
- }
- print TEMP "$_\n";
- /^@@ -\d+,(\d+) \+\d+,(\d+) @@/ || error("Malformed patch");
- $old = $1;
- $new = $2;
- while ($old || $new) {
- $_ = <STDIN>;
- print TEMP $_;
- if (/^ /) { $old--; $new--; }
- elsif (/^-/) { $old--; }
- elsif (/^\+/) { $new--; }
- else { error("Malformed patch"); }
- if ($old<0 || $new<0) { error("Malformed patch"); }
- }
- }
- }
- }
-}
-error("No patch found");
-
-sub cleanup
-{
- chdir($home);
- `rm -rf $tprefix` unless $debug;
- exit 0;
-}
-
-sub blackhole
-{
- my $reason = shift @_;
- print STDERR "Blackholed: $reason\n";
- cleanup();
-}
-
-sub error
-{
- my $reason = shift @_;
- print LOG "$reason\n";
- mail_reply($reason);
- cleanup();
-}
-
-sub process
-{
- print LOG "Patch found.\n";
- print LOG "Searching for original pci.ids version.\n";
- foreach $orig (($original eq "") ? glob("$home/origs/*") : ("../../$original")) {
- print LOG "Trying $orig\n";
- unlink "pci.ids";
- unlink "pci.rej";
- print LOG `/usr/bin/patch <patch --no-backup -o pci.ids -r pci.rej $orig`;
- if ($?) {
- print LOG "Failed.\n";
- } else {
- print LOG "Patch succeeded.\n";
- print LOG "Parsing patched file.\n";
- print LOG `$home/tools/ids_to_dbdump <$orig 2>&1 >orig.db.unsorted`;
- $? && error("Error parsing original ID database");
- print LOG `sort +1 <orig.db.unsorted >orig.db`;
- $? && error("Error sorting original ID database");
- print LOG `$home/tools/ids_to_dbdump <pci.ids 2>&1 >new.db.unsorted`;
- $? && error("Error parsing the patched pci.ids file");
- print LOG `sort +1 <new.db.unsorted >new.db`;
- $? && error("Error sorting the patched pci.ids file");
- print LOG "Finding ID differences.\n";
- `diff -U0 new.db orig.db >diffs`;
- if ($? > 256) { error("Diff failed. Why?"); }
- elsif (!$?) { error("No ID changes encountered."); }
- open(DIFF, "diffs") || error("Cannot open the diff");
- $subject = undef if $subject eq '';
- my $authorId = getAuthor( $author );
- my $live = (!$emulate && !$debug);
- while (<DIFF>) {
- chomp;
- /^(\+\+\+|---)/ && next;
- /^[+-]/ || next;
- ($tt,$id,$name,$stat,$cmt) = split /\t/;
- if ($tt =~ /^\+(.*)/) {
- defined $seen{$id} && next;
- $name = $cmt = "";
- } elsif ($tt =~ /^-(.*)/) {
- $seen{$id} = 1;
- } else { error("Internal bug #23"); }
- print LOG "$id\t$name\t$cmt\n";
- submitItem( $id, $name, $cmt, $subject, $authorId ) if $live;
- }
- $dbh->commit();
- close DIFF;
- $time = localtime;
- `echo >>$home/log/mailbot.log "## $time $reply"`;
- `cat result >>$home/log/mailbot.log`;
- print LOG "Done.\n";
- mail_reply("OK");
- cleanup();
- }
- }
- error("Unable to find any version of pci.ids the patch applies to.");
-}
-
-sub mail_reply
-{
- my $reason = shift @_;
- my $sendmail_opts = "-fmj+iderr\@ucw.cz '$reply_plain' mj+idecho\@ucw.cz";
- if ($debug || $reply eq "") {
- print "$reason\n";
- return;
- } elsif ($emulate) {
- open(MAIL, ">&STDOUT") || die;
- print MAIL "SENDMAIL $sendmail_opts\n";
- } elsif (!open MAIL, "|/usr/sbin/sendmail $sendmail_opts") {
- print STDERR "Unable to ask mailer for replying!!!\n";
- print LOG "Unable to ask mailer for replying!!!\n";
- exit 1;
- }
- print MAIL "From: The PCI ID Robot <mj+iderr\@ucw.cz>\n";
- print MAIL "To: $reply\n";
- print MAIL "Subject: IDbot: $reason\n";
- print MAIL "In-Reply-To: $msgid\n" if $msgid ne "";
- print MAIL "\n";
- print MAIL <<EOF
-This is an automatic reply from the PCI ID Mail Robot. If you want to contact
-the administrator of the robot, please write to pciids-devel\@lists.sourceforge.net.
-
-EOF
-;
- if ($reason eq "OK") {
- print MAIL "Your submission has been accepted.\n\n";
- } else {
- print MAIL <<EOF
-Your submission has been rejected. Please make sure that the mail you've sent
-is a unified diff (output of diff -u) against the latest pci.ids file, that
-the diff is not reversed and that your mailer doesn't damage long lines
-and doesn't change tabs to spaces or vice versa. Also, we don't accept MIME
-attachments in base64 encoding yet. If you are unable to fix your problems,
-just use the Web interface at http://pciids.sf.net/ or submit the patch
-to pciids-devel\@lists.sourceforge.net where it will be processed manually.
-See the log below for additional information.
-
-EOF
-;
- }
- print MAIL "--- Processing Log ---\n\n";
- if (open L, "<log") {
- while (<L>) { print MAIL "$_"; }
- close L;
- }
- print MAIL "\n--- End ---\n";
- close MAIL;
-}
-
-sub url_encode
-{
- $_ = shift @_;
- s/([^a-zA-Z0-9.!*,_-])/'%'.unpack('H2',$1)/ge;
- s/%20/+/g;
- $_;
-}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use PciIds::DBQAny;
-use PciIds::Users;
-
-my( $privnums, $privnames ) = getRightDefs();
-
-sub userRights( $$ ) {
- my( $tables, $user ) = @_;
- foreach( @{$tables->query( 'rightsName', [ $user, $user ] )} ) {
- my( $rid ) = @{$_};
- print " $privnames->{$rid} ($rid)\n";
- }
-}
-
-my $dbh = connectDb();
-my $tables = PciIds::DBQAny::new( $dbh, {
- 'rightsName' => 'SELECT rightId FROM users INNER JOIN rights ON users.id = rights.userId WHERE users.email = ? OR users.login = ? ORDER BY rightId',
- 'allrights' => 'SELECT users.id, users.login, users.email, rights.rightId FROM users INNER JOIN rights ON users.id = rights.userId ORDER BY users.login, users.email, users.id, rights.rightId',
- 'getId' => 'SELECT id FROM users WHERE email = ? OR login = ?',
- 'add' => 'INSERT INTO rights (userId, rightId) VALUES(?, ?)',
- 'del' => 'DELETE FROM rights WHERE userId = ? AND rightId = ?'
-});
-
-while( scalar @ARGV ) {
- my $cmd = shift @ARGV;
- if( $cmd eq '-a' ) {
- my $lastid = undef;
- foreach( @{$tables->query( 'allrights', [] )} ) {
- my( $id, $name, $mail, $rid ) = @{$_};
- if( $id != $lastid ) {
- print "$mail ($id)\t$name\n";
- $lastid = $id;
- }
- print " $privnames->{$rid} ($rid)\n";
- }
- } elsif( $cmd =~ /^[+-]l?$/ ) {
- my $user = shift @ARGV;
- my $id = $tables->query( 'getId', [ $user, $user ] )->[ 0 ]->[ 0 ];
- die "Invalid user $user\n" unless( defined $id );
- my $right = $privnums->{shift @ARGV};
- die "Invalid right $right\n" unless( defined $right );
- my @params = ( $id, $right );
- my $q = ( $cmd =~ /-/ ) ? 'del' : 'add';
- $tables->command( $q, \@params );
- } elsif( $cmd eq '-h' ) {
- print "rights.pl username\t\t\tPrint user's rights\n";
- print "rights.pl -a\t\t\t\tPrint all users and their rights\n";
- print "rights.pl +/- user right\t\tGrant/revoke user's right\n";
- } else {
- print "$cmd\n";
- userRights( $tables, $cmd );
- }
-}
-$dbh->commit();
-$dbh->disconnect();
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::DBQ;
-use PciIds::Db;
-use PciIds::Notifications;
-use PciIds::Xmpp;
-
-my $dbh = connectDb();
-my $tables = PciIds::DBQ::new( $dbh );
-
-sendNotifs( $tables );
-flushXmpp();
-$tables->commit();
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-BEGIN {
- unshift @INC, ".";
-}
-use PciIds::Db;
-use PciIds::Config;
-use DBI;
-
-my( $orig ) = @ARGV;
-my $newdb = connectDb();
-my( $user, $passwd ) = confList( [ "dbuser", "dbpasswd" ] );
-my $olddb = DBI->connect( "dbi:mysql:$orig", $user, $passwd, { 'RaiseError' => 1 } );
-
-print "Submiting ordinary users\n";
-my $uquery = $olddb->prepare( "SELECT DISTINCT author FROM ids WHERE author like '%@%'" );
-my $upush = $newdb->prepare( "INSERT INTO users (email, passwd) VALUES (?, '')" );
-$uquery->execute();
-my %users = ( '' => undef );
-
-while( my( $author ) = $uquery->fetchrow_array ) {
- $upush->execute( $author );
- $users{$author} = $newdb->last_insert_id( undef, undef, undef, undef );
-}
-
-my $clean = $newdb->prepare( "DELETE FROM locations WHERE id like 'PC/%'" );
-print "Cleaning old PCI devices to make place for new ones\n";
-$clean->execute();
-print "Submiting items from database\n";
-
-my $itemq = $olddb->prepare( "SELECT id, name, comment, author, status, type FROM ids ORDER BY LENGTH(id), id" );
-my $itemp = $newdb->prepare( "INSERT INTO locations (id, parent) VALUES (?, ?)" );
-my $comp = $newdb->prepare( "INSERT INTO history (owner, location, nodename, nodedescription, seen, time) VALUES (?, ?, ?, ?, ?, '2000-01-01 00:00:00')" );
-my $setMain = $newdb->prepare( 'UPDATE locations SET
- maincomment = ?,
- name = ( SELECT nodename FROM history WHERE id = ? ),
- description = ( SELECT nodedescription FROM history WHERE id = ? )
- WHERE
- id = ?' );
-
-my %rex = (
- 'v' => sub {
- my $i = shift;
- "PC/$i";
- },
- 'd' => sub {
- my $i = shift;
- $i =~ s/(.{4,4})(.*)/PC\/$1\/$2/;
- return $i;
- },
- 's' => sub {
- my $i = shift;
- $i =~ s/(.{4,4})(.{4,4})(.*)/PC\/$1\/$2\/$3/;
- return $i;
- }
-);
-
-$itemq->execute();
-while( my( $id, $name, $description, $author, $status, $type ) = $itemq->fetchrow_array ) {
- $id = &{$rex{$type}}( $id );
- my $parent = $id;
- $parent =~ s/\/[^\/]+$//;
- eval {#Add it if not present yet
- $itemp->execute( $id, $parent );
- };
- $author = '' unless( defined $author );
- $comp->execute( $users{$author} ? $users{$author} : undef, $id, $name, $description, !$status );
- unless( $status ) {
- my $last = $newdb->last_insert_id( undef, undef, undef, undef );
- $setMain->execute( $last, $last, $last, $id );
- }
-}
-
-$newdb->commit();
-$newdb->disconnect();
+++ /dev/null
-.menu, .navigation
-{
- overflow: hidden;
- display: none;
-}
-.author, .time
-{
- font-style: italic;
-}
-.itemname, .name
-{
- font-weight: bold;
-}
-.itemdescription, .description
-{
- font-style: italic;
- font-weight: bold;
-}
-.unnamedItem
-{
- font-style: italic;
-}
-.comment, .unseen-comment, .main-comment
-{
- border-bottom: dotted;
- border-bottom-width: 1px;
-}
+++ /dev/null
-body
-{
- color: black;
- background: #DDDDFF;
-}
-.unnamedItem, .unseen-comment
-{
- background: #D5D5D5;
-}
-.item, .comment
-{
- background: #F0F0F0;
-}
-.main-comment
-{
- background: #DDFFDD;
-}
-.itemname, .name
-{
- font-weight: bold;
-}
-.itemdescription, .description
-{
- font-weight: bold;
- font-style: italic;
-}
-.error
-{
- font-weight: bold;
- color: red;
-}
-.author, .time
-{
- font-style: italic;
- color: #444444;
-}
-.discussion div p, .admin div p
-{
- padding-left: 5px;
- padding-right: 5px;
-}
-.menu ul
-{
- list-style-type: none;
-}
+++ /dev/null
-@users
-#Each row represents a registered user, with privileges or without
-id INT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE PRIMARY KEY,#Internal ID
-email VARCHAR(255) <<CHARSET>> UNIQUE NOT NULL,#His email for notifications
-xmpp TEXT <<CHARSET>>,#His XMPP address for notifications
-login VARCHAR(50) <<CHARSET>> UNIQUE,#Login name
-passwd VARCHAR(22) <<CHARSET>> NOT NULL,#Password hash
-lastlog TEXT <<CHARSET>>,#Where did he logged in last time?
-logtime TIMESTAMP,#When did he log in last time?
-mailgather INT UNSIGNED NOT NULL DEFAULT 240,#How long to gather mail notifications before sending?
-xmppgather INT UNSIGNED NOT NULL DEFAULT 15,#How long to gather xmpp notifications before sending?
-nextmail TIMESTAMP,#When do we send pending email notifications next time?
-nextxmpp TIMESTAMP#When do we send pending xmpp notifications?
-
-@locations
-#The locations are saved in a tree. ID of the location is created by
-#appending the local IDs of the nodes on the path together (children of
-#the root first), separated by '/'. Each node must know, how long are
-#the local IDs of its children.
-#
-#(Note that the local IDs can contain '/', since it can be recognized
-#by its length.)
-#
-#The first part is 2-letter specifier of information type. The first
-#version has these:
-#PC: PCI ID
-#PD: PCI Device Class
-#
-id VARCHAR(50) <<CHARSET>> NOT NULL UNIQUE PRIMARY KEY,#The name of the location, must be just node, no / at the end
-parent VARCHAR(50) <<CHARSET>>,#To allow selecting of all node's children
-maincomment INT UNSIGNED,#Reference for the main comment
-name TINYTEXT <<CHARSET>>,#Should match the one of main comment, if any (if no main comment, name can be set too)
-description TEXT <<CHARSET>>,#Should match the one of main comment (if no main comment, can be set too)
-CONSTRAINT parent_ref FOREIGN KEY (parent) REFERENCES locations(id) ON DELETE CASCADE
-
-@rights
-#Which privileges the users have?
-#It contains only the users with some extra privileges, not the normal ones
-userId INT UNSIGNED NOT NULL,#Who has the privilege
-rightId INT UNSIGNED NOT NULL,#What privilege
-CONSTRAINT right_user FOREIGN KEY (userId) REFERENCES users(id) ON DELETE CASCADE,
-PRIMARY KEY (userId, rightId)
-
-@history
-#Contains the comments in the discussion
-id INT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE PRIMARY KEY,
-owner INT UNSIGNED,#Who posted it?
-location VARCHAR(50) <<CHARSET>> NOT NULL,#Where it belongs
-text TEXT <<CHARSET>>,
-time TIMESTAMP NOT NULL DEFAULT NOW(),#When this was added
-nodename TINYTEXT <<CHARSET>>,#Modification of the location name
-nodedescription TEXT <<CHARSET>>,#Modification of the location comment
-seen BOOLEAN NOT NULL DEFAULT '0', #Did some admin see this, or is it still unseen?
-CONSTRAINT history_location FOREIGN KEY (location) REFERENCES locations(id) ON DELETE CASCADE,
-CONSTRAINT history_owner FOREIGN KEY (owner) REFERENCES users(id) ON DELETE SET NULL
-
-@notifications
-#Contains hooks for notifications
-user INT UNSIGNED NOT NULL,#Who wants it
-location VARCHAR(50) <<CHARSET>> NOT NULL,#Where
-recursive BOOLEAN NOT NULL DEFAULT '0',
-type SMALLINT NOT NULL,#When to send
-#0: Comment -- When a new comment is posted
-#1: Description -- Name or comment changed
-#2: MainComment -- The main comment changed
-#All contains the less common events
-notification SMALLINT NOT NULL,
-#0: mail only
-#1: xmpp only
-#2: both
-CONSTRAINT notification_location FOREIGN KEY (location) REFERENCES locations(id) ON DELETE CASCADE,
-CONSTRAINT notification_user FOREIGN KEY (user) REFERENCES users(id) ON DELETE CASCADE,
-PRIMARY KEY (user, location)
-
-@pending
-#Contains the pending notifications
-user INT UNSIGNED NOT NULL,
-comment INT UNSIGNED NOT NULL,
-notification SMALLINT NOT NULL,
-#0: mail
-#1: xmpp
-#If a notification generates both, it splits to 2 of them
-reason SMALLINT NOT NULL,
-#0: New item
-#1: New comment
-#2: Changed main article
-CONSTRAINT pending_comment FOREIGN KEY (comment) REFERENCES history(id) ON DELETE CASCADE,
-CONSTRAINT pending_user FOREIGN KEY (user) REFERENCES users(id) ON DELETE CASCADE
+++ /dev/null
- PCI IDčkovátko
-================
-Webová aplikace pro ukládání a updatování informací o PCI ID zařízení.
-Je to přepsání již existující a nasazené aplikace, která postrádá
-některé žádané schopnosti (http://pci-ids.ucw.cz/).
-
-Ke každému objektu (tedy, PCI ID, ID výrobce, ID subsystému, ID třídy
-zařízení) bude možno vést diskusi, ve které bude možnost jednak psát
-komentáře a jednak zasílat nové verze popisu ID. Pro tuto diskusi bude
-možné objednat upozornění mailem (a to buď pro každou úpravu zvlášť,
-nebo dávkově).
-
-Diskuse bude chráněná registrací s ověřením emailové adresy. Tato
-adresa bude jednak zobrazena a zpřístupněna administrátorům, jednak
-bude sloužit k zasílání upozornění.
-
-Administrátor bude mít schopnost mazat příspěvky. Taktéž bude moct
-označit (či odznačit) některou verzi informací o daném ID jako
-finální.
--- /dev/null
+1 validate
+2 listUsers
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use DBI;
+
+my $dbh = connectDb();
+$dbh->prepare( 'DELETE FROM locations' )->execute();
+$dbh->prepare( 'DELETE FROM history' )->execute();
+$dbh->commit();
+$dbh->disconnect();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use PciIds::DBQAny;
+
+my $db = PciIds::DBQAny::new( connectDb(), {
+ 'list' => 'SELECT id, name, description FROM locations WHERE name IS NOT NULL ORDER BY id'
+} );
+
+foreach( @{$db->query( 'list', [] )} ) {
+ my( $id, $name, $description ) = @{$_};
+ $_ = $id;
+ my $prefix = ( /^PC/ ) ? '' : 'C ';
+ s/^P.\///;
+ s/[^\/]//g;
+ s/\//\t/g;
+ my $tabs = $_;
+ $id =~ s/.*\///;
+ print "$tabs$prefix$id $name\n";
+ if( defined( $description ) && ( $description ne '' ) ) {
+ chomp $description;
+ $description =~ s/\n/\n$tabs#/g;
+ print "$tabs#$description\n";
+ }
+}
+
+$db->commit();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use DBI;
+
+my $dbh = connectDb();
+my $query = $dbh->prepare( "INSERT INTO locations (id, name, description, parent) VALUES(?, ?, ?, ?);" ) or die "Could not create the query (".DBI->errstr.")\n";
+my $comment = $dbh->prepare( "INSERT INTO history (location, nodename, nodedescription, seen) VALUES(?, ?, ?, '1')" ) or die "Could not create query (".DBI->errstr.")\n";
+my $update = $dbh->prepare( "UPDATE locations SET maincomment = ? WHERE id = ?" ) or die "Could not create query (".DBI->errstr.")\n";
+my( $vendor, $type, $sub, $description, $name );
+
+$query->execute( "PC", undef, undef, undef ) or die "Could not add toplevel node\n";
+$query->execute( "PD", undef, undef, undef ) or die "Could not add toplevel node\n";
+
+sub submit( $ ) {
+ my( $id ) = @_;
+ my $parent = $id;
+ $parent =~ s/\/[^\/]+$//;
+ $query->execute( $id, $name, $description, $parent );
+ $comment->execute( $id, $name, $description );
+ my $com = $dbh->last_insert_id( undef, undef, undef, undef );
+ $update->execute( $com, $id );
+ undef $description;
+}
+
+print "Filling database from id file\n";
+
+foreach( <> ) {
+ chomp;
+ if( s/^\s*#\s*// ) {
+ $description = $_;
+ } elsif( /^\s*$/ ) {
+ undef $description;
+ } elsif( /^\t\t/ ) {
+ if( $vendor =~ /^PC/ ) {
+ ( $sub, $name ) = /^\s*([0-9a-fA-F]+\s[0-9a-fA-F]+)\s+(.*)$/;
+ $sub =~ s/\s+//g;
+ } else {
+ ( $sub, $name ) = /^\s*([0-9a-fA-F]+)\s+(.*)$/;
+ }
+ submit( $vendor.'/'.$type.'/'.$sub );
+ } elsif( /^\t/ ) {
+ ( $type, $name ) = /^\s*([0-9a-fA-F]+)\s+(.*)$/;
+ submit( $vendor.'/'.$type );
+ } elsif( /^C\s/ ) {
+ ( $vendor, $name ) = /^C\s+([0-9a-fA-F]+)\s+(.*)$/;
+ $vendor = 'PD/'.$vendor;
+ submit( $vendor );
+ } elsif( /^[0-9a-fA-F]/ ) {
+ ( $vendor, $name ) = /([0-9a-fA-F]+)\s+(.*)$/;
+ $vendor = 'PC/'.$vendor;
+ submit( $vendor );
+ } else {
+ die "Um what?? $_\n";
+ }
+}
+$dbh->commit();
+$dbh->disconnect;
--- /dev/null
+#!/usr/bin/perl
+use strict;
+BEGIN {
+ unshift @INC, ".";
+};
+use PciIds::Db;
+
+my %tracked;
+
+sub translateLoc( $ ) {
+ my $loc = shift;
+ $loc =~ s/(.{8})(.+)/$1\/$2/;
+ $loc =~ s/(.{4})(.+)/$1\/$2/;
+ return "PC/$loc";
+}
+
+my $dbh = connectDb();
+my $clearHist = $dbh->prepare( 'DELETE FROM history WHERE location = ?' );
+my %coms;
+my $com = $dbh->prepare( 'INSERT INTO history (owner, location, time, nodename, nodedescription) VALUES (?, ?, FROM_UNIXTIME(?), ?, ?)' );
+my $user = $dbh->prepare( 'SELECT id FROM users WHERE email = ?' );
+my $delHis = $dbh->prepare( 'DELETE FROM history WHERE id = ?' );
+my $markMain = $dbh->prepare( 'UPDATE locations SET
+ maincomment = ?,
+ name = ( SELECT nodename FROM history WHERE id = ? ),
+ description = ( SELECT nodedescription FROM history WHERE id = ? )
+ WHERE
+ id = ?' );
+my $markSeen = $dbh->prepare( "UPDATE history SET seen = '1' WHERE id = ?" );
+
+sub getUser( $ ) {
+ $user->execute( shift );
+ if( my( $id ) = $user->fetchrow_array ) {
+ return $id;
+ } else {
+ return undef;
+ }
+}
+
+my $accept = 0;
+my $reject = 0;
+my $del = 0;
+my $appr = 0;
+
+print "Parsing and importing log\n";
+
+foreach( <> ) {
+ my( $time, $who, $ip, $command, $id, $location, $name, $description, $email );
+ if( ( $time, $who, $ip, $command, $id, $location, $name, $description, $email ) = /^(\d+) (\S+) ([0-9.]+) (Create|Batch submit:) (\d+) ([0-9a-f]+) '(.*)(?<!\\)' '(.*)(?<!\\)' '(.*)(?<!\\)'/ ) {
+ my $translated = translateLoc( $location );
+ unless( $tracked{$location} ) {#From now on, it is restored from the log
+ $tracked{$location} = 1;
+ $clearHist->execute( $translated );
+ }
+ $name =~ s/\\(.)/$1/g;
+ $description =~ s/\\(.)/$1/g;
+ $name = undef if( $name eq '' );
+ $description = undef if( $description eq '' );
+ eval {#If the item is not here at all, it was deleted -> no need to add it here
+ $com->execute( getUser( $email ), $translated, $time, $name, $description );
+ $coms{$id} = $dbh->last_insert_id( undef, undef, undef, undef );
+ $accept ++;
+ };
+ if( $@ ) {
+ $reject ++;
+ }
+ } elsif( ( $time, $who, $ip, $command, $id, $location, $description, $email ) = /^(\d+) (\S+) ([0-9.]+) (Approve|Delete|Overriden) (\d+) ([0-9a-f]+) '(.*)(?<!\\)' '(.*)(?<!\\)'/ ) {
+ next unless( defined( $coms{$id} ) );#This one not tracked yet
+ if( $command eq 'Approve' ) {
+ my $i = $coms{$id};
+ $markMain->execute( $i, $i, $i, translateLoc( $location ) );
+ $markSeen->execute( $i );
+ $appr ++;
+ } elsif( $command eq 'Delete' ) {
+ $delHis->execute( $coms{$id} );
+ $del ++;
+ } else {
+ $markSeen->execute( $coms{$id} );
+ }
+ } else {
+ print "Unparsed line: $_";
+ }
+}
+
+$dbh->commit();
+$dbh->disconnect();
--- /dev/null
+./scripts/initdb.pl
+./scripts/feeddb.pl pci.ids
+./scripts/transfer.pl pciidsold
+./scripts/importlog.pl iii.log
+echo 'Database is prepared, but it does not contain admins. Add them manually, please.'
+echo 'Just register like ordinary user and run ./scripts/rights.pl + username validate'
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Config;
+use PciIds::Db;
+use DBI;
+
+my @lines;
+my $tablename;
+
+defConf( { "dbcharset" => "UTF8", "dbtype" => "InnoDB" } );
+
+my %replaces = (
+ "CHARSET" => "CHARSET ".$config{"dbcharset"}
+);
+
+sub createTable( $ ) {
+ die "Invalid table definition\n" unless( defined( $tablename ) && @lines );
+ my $nt = $_[ 0 ]->prepare( "CREATE TABLE ".$tablename." (".( join "\n", @lines ).") TYPE = $config{dbtype};" );
+ $nt->execute();
+ @lines = ();
+ print "Created table $tablename\n";
+ undef $tablename;
+}
+
+my $dbh = connectDb();
+open TABLES, "tables" or die "Could not open table definitions\n";
+foreach( <TABLES> ) {
+ chomp;
+ if( /^\s*$/ ) {
+ createTable( $dbh );
+ } elsif( s/^@// ) {
+ $tablename = $_;
+ } else {
+ s/#.*//;
+ s/<<([^<>]+)>>/$replaces{$1}/g;
+ push @lines, $_;
+ }
+}
+close TABLES;
+createTable( $dbh );
+$dbh->commit();
+$dbh->disconnect;
--- /dev/null
+#!/usr/bin/perl
+# Mail robot for processing of PCI ID submissions
+# (c) 2001--2002 Martin Mares <mj@ucw.cz>
+# 2008 Michal Vaner <vorner@ucw.cz>
+
+use Mail::Header;
+use Getopt::Long;
+use IO::Handle;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use PciIds::Log;
+use PciIds::Notifications;
+use PciIds::DBQ;
+
+my $patch = 0;
+my $emulate = 0;
+my $debug = 0;
+my $original = "";
+my $author = "";
+GetOptions(
+ 'patch!' => \$patch,
+ 'emulate!' => \$emulate,
+ 'debug!' => \$debug,
+ 'orig=s' => \$original,
+ 'author=s' => \$author
+) || die "Usage: mailbot [--patch] [--emulate] [--debug] [--orig <name>] [--author <mailaddr>]";
+
+my $reply = "";
+my $reply_plain = "";
+my $msgid = "";
+my $subject = "";
+my $tables = PciIds::DBQ::new( connectDb() );
+
+my $hasAuth = $tables->dbh()->prepare( 'SELECT id FROM users WHERE email = ?' );
+my $addAuth = $tables->dbh()->prepare( "INSERT INTO users (email, passwd) VALUES(?, '')" );
+my $hasItem = $tables->dbh()->prepare( "SELECT 1 FROM locations WHERE id = ?" );
+my $addItem = $tables->dbh()->prepare( "INSERT INTO locations (id, parent) VALUES (?, ?)" );
+my $addComment = $tables->dbh()->prepare( "INSERT INTO history (owner, location, text, nodename, nodedescription) VALUES (?, ?, ?, ?, ?)" );
+
+sub getAuthor( $ ) {
+ my( $mail ) = @_;
+ $hasAuth->execute( $mail );
+ if( my( $id ) = $hasAuth->fetchrow_array ) {
+ return $id;
+ } else {
+ tlog( "mailbot: Creating user $mail" );
+ $addAuth->execute( $mail );
+ my $nid = $dbh->last_insert_id( undef, undef, undef, undef );
+ tlog( "mailbot: User ($mail) id: $nid" );
+ return $nid;
+ }
+}
+
+sub submitItem( $$$$$ ) {
+ my( $id, $name, $description, $text, $author ) = @_;
+ my $created;
+ $id =~ s/(.{8})(.*)/$1\\$2/;
+ $id =~ s/(.{4})(.*)/$1\\$2/;
+ $id = "PC/$id";
+ $hasItem->execute( $id );
+ unless( $hasItem->fetchrow_array ) {
+ tlog( "mailbot: Item created (empty) $id" );
+ my $parent = $id;
+ $parent =~ s/\/[^\/]*//;
+ $addItem->execute( $id, $parent );
+ $created = 1;
+ }
+ $addComment->execute( $author, $id, $text, $name, $description );
+ my $hid = $tables->last();
+ tlog( "mailbot: Comment created $hid $id ".logEscape( $name )." ".logEscape( $description )." ".logEscape( $text ) );
+ notify( $tables, $id, $hid, $created ? 2 : 1, $created ? 0 : 1 );
+}
+
+if (!$patch) {
+ $hdr = new Mail::Header;
+ $hdr->modify(1);
+ $hdr->mail_from(COERCE);
+ $hdr->read(*STDIN{IO});
+ $hdr->unfold();
+ $mfrom = $hdr->get('Mail-From');
+ chomp $mfrom;
+ ($mfrom =~ /^MAILER-DAEMON@/i) && blackhole("From mailer daemon");
+ $mfrom =~ s/ .*// or blackhole("Malformed envelope sender");
+ ($reply = $hdr->get('Reply-To')) || ($reply = $hdr->get('From')) ||
+ blackhole("Don't know who should I reply to");
+ chomp $reply;
+ if ($reply =~ /<(\S*)>/) {
+ $reply_plain = $1;
+ } elsif ($reply =~ /^\S+$/) {
+ $reply_plain = $reply;
+ } else {
+ $reply_plain = $mfrom;
+ }
+ $reply_plain =~ tr/\n'"\\//d;
+ $msgid = $hdr->get('Message-Id');
+ chomp $msgid;
+ my $subj = $hdr->get('Subject');
+ chomp $subj;
+ if ($subj =~ /^IDS: (.*)/) {
+ $subject = $1;
+ }
+ $author = $reply_plain;
+}
+
+$tprefix = "tmp/mbot-$$";
+$home = "../..";
+mkdir("tmp", 0777);
+mkdir($tprefix, 0777) || error("Cannot create tmpdir");
+chdir($tprefix) || error("Cannot chdir to tmpdir");
+
+open(TEMP, ">patch") || error("Cannot create tmpfile");
+if ($debug || $reply eq "") {
+ open(LOG, ">&STDOUT") || error ("Cannot create outfile");
+} else {
+ open(LOG, ">log") || error ("Cannot create outfile");
+ LOG->autoflush(1);
+}
+if ($reply) {
+ print LOG "Got mail from $reply, will reply to $reply_plain.\n";
+ print LOG "Scanning mail for patch.\n";
+} else {
+ print LOG "Scanning STDIN for patch.\n";
+}
+while (<STDIN>) {
+ while (/^--- /) {
+ $l0 = $_;
+ $_ = <STDIN>;
+ if (/^\+\+\+ /) {
+ print TEMP $l0;
+ print TEMP $_;
+ while (1) {
+ $_ = <STDIN>;
+ chomp;
+ if (/^\s*$/ || !/^[ +\@-]/) {
+ close TEMP;
+ process();
+ exit 0;
+ }
+ print TEMP "$_\n";
+ /^@@ -\d+,(\d+) \+\d+,(\d+) @@/ || error("Malformed patch");
+ $old = $1;
+ $new = $2;
+ while ($old || $new) {
+ $_ = <STDIN>;
+ print TEMP $_;
+ if (/^ /) { $old--; $new--; }
+ elsif (/^-/) { $old--; }
+ elsif (/^\+/) { $new--; }
+ else { error("Malformed patch"); }
+ if ($old<0 || $new<0) { error("Malformed patch"); }
+ }
+ }
+ }
+ }
+}
+error("No patch found");
+
+sub cleanup
+{
+ chdir($home);
+ `rm -rf $tprefix` unless $debug;
+ exit 0;
+}
+
+sub blackhole
+{
+ my $reason = shift @_;
+ print STDERR "Blackholed: $reason\n";
+ cleanup();
+}
+
+sub error
+{
+ my $reason = shift @_;
+ print LOG "$reason\n";
+ mail_reply($reason);
+ cleanup();
+}
+
+sub process
+{
+ print LOG "Patch found.\n";
+ print LOG "Searching for original pci.ids version.\n";
+ foreach $orig (($original eq "") ? glob("$home/origs/*") : ("../../$original")) {
+ print LOG "Trying $orig\n";
+ unlink "pci.ids";
+ unlink "pci.rej";
+ print LOG `/usr/bin/patch <patch --no-backup -o pci.ids -r pci.rej $orig`;
+ if ($?) {
+ print LOG "Failed.\n";
+ } else {
+ print LOG "Patch succeeded.\n";
+ print LOG "Parsing patched file.\n";
+ print LOG `$home/tools/ids_to_dbdump <$orig 2>&1 >orig.db.unsorted`;
+ $? && error("Error parsing original ID database");
+ print LOG `sort +1 <orig.db.unsorted >orig.db`;
+ $? && error("Error sorting original ID database");
+ print LOG `$home/tools/ids_to_dbdump <pci.ids 2>&1 >new.db.unsorted`;
+ $? && error("Error parsing the patched pci.ids file");
+ print LOG `sort +1 <new.db.unsorted >new.db`;
+ $? && error("Error sorting the patched pci.ids file");
+ print LOG "Finding ID differences.\n";
+ `diff -U0 new.db orig.db >diffs`;
+ if ($? > 256) { error("Diff failed. Why?"); }
+ elsif (!$?) { error("No ID changes encountered."); }
+ open(DIFF, "diffs") || error("Cannot open the diff");
+ $subject = undef if $subject eq '';
+ my $authorId = getAuthor( $author );
+ my $live = (!$emulate && !$debug);
+ while (<DIFF>) {
+ chomp;
+ /^(\+\+\+|---)/ && next;
+ /^[+-]/ || next;
+ ($tt,$id,$name,$stat,$cmt) = split /\t/;
+ if ($tt =~ /^\+(.*)/) {
+ defined $seen{$id} && next;
+ $name = $cmt = "";
+ } elsif ($tt =~ /^-(.*)/) {
+ $seen{$id} = 1;
+ } else { error("Internal bug #23"); }
+ print LOG "$id\t$name\t$cmt\n";
+ submitItem( $id, $name, $cmt, $subject, $authorId ) if $live;
+ }
+ $dbh->commit();
+ close DIFF;
+ $time = localtime;
+ `echo >>$home/log/mailbot.log "## $time $reply"`;
+ `cat result >>$home/log/mailbot.log`;
+ print LOG "Done.\n";
+ mail_reply("OK");
+ cleanup();
+ }
+ }
+ error("Unable to find any version of pci.ids the patch applies to.");
+}
+
+sub mail_reply
+{
+ my $reason = shift @_;
+ my $sendmail_opts = "-fmj+iderr\@ucw.cz '$reply_plain' mj+idecho\@ucw.cz";
+ if ($debug || $reply eq "") {
+ print "$reason\n";
+ return;
+ } elsif ($emulate) {
+ open(MAIL, ">&STDOUT") || die;
+ print MAIL "SENDMAIL $sendmail_opts\n";
+ } elsif (!open MAIL, "|/usr/sbin/sendmail $sendmail_opts") {
+ print STDERR "Unable to ask mailer for replying!!!\n";
+ print LOG "Unable to ask mailer for replying!!!\n";
+ exit 1;
+ }
+ print MAIL "From: The PCI ID Robot <mj+iderr\@ucw.cz>\n";
+ print MAIL "To: $reply\n";
+ print MAIL "Subject: IDbot: $reason\n";
+ print MAIL "In-Reply-To: $msgid\n" if $msgid ne "";
+ print MAIL "\n";
+ print MAIL <<EOF
+This is an automatic reply from the PCI ID Mail Robot. If you want to contact
+the administrator of the robot, please write to pciids-devel\@lists.sourceforge.net.
+
+EOF
+;
+ if ($reason eq "OK") {
+ print MAIL "Your submission has been accepted.\n\n";
+ } else {
+ print MAIL <<EOF
+Your submission has been rejected. Please make sure that the mail you've sent
+is a unified diff (output of diff -u) against the latest pci.ids file, that
+the diff is not reversed and that your mailer doesn't damage long lines
+and doesn't change tabs to spaces or vice versa. Also, we don't accept MIME
+attachments in base64 encoding yet. If you are unable to fix your problems,
+just use the Web interface at http://pciids.sf.net/ or submit the patch
+to pciids-devel\@lists.sourceforge.net where it will be processed manually.
+See the log below for additional information.
+
+EOF
+;
+ }
+ print MAIL "--- Processing Log ---\n\n";
+ if (open L, "<log") {
+ while (<L>) { print MAIL "$_"; }
+ close L;
+ }
+ print MAIL "\n--- End ---\n";
+ close MAIL;
+}
+
+sub url_encode
+{
+ $_ = shift @_;
+ s/([^a-zA-Z0-9.!*,_-])/'%'.unpack('H2',$1)/ge;
+ s/%20/+/g;
+ $_;
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use PciIds::DBQAny;
+use PciIds::Users;
+
+my( $privnums, $privnames ) = getRightDefs();
+
+sub userRights( $$ ) {
+ my( $tables, $user ) = @_;
+ foreach( @{$tables->query( 'rightsName', [ $user, $user ] )} ) {
+ my( $rid ) = @{$_};
+ print " $privnames->{$rid} ($rid)\n";
+ }
+}
+
+my $dbh = connectDb();
+my $tables = PciIds::DBQAny::new( $dbh, {
+ 'rightsName' => 'SELECT rightId FROM users INNER JOIN rights ON users.id = rights.userId WHERE users.email = ? OR users.login = ? ORDER BY rightId',
+ 'allrights' => 'SELECT users.id, users.login, users.email, rights.rightId FROM users INNER JOIN rights ON users.id = rights.userId ORDER BY users.login, users.email, users.id, rights.rightId',
+ 'getId' => 'SELECT id FROM users WHERE email = ? OR login = ?',
+ 'add' => 'INSERT INTO rights (userId, rightId) VALUES(?, ?)',
+ 'del' => 'DELETE FROM rights WHERE userId = ? AND rightId = ?'
+});
+
+while( scalar @ARGV ) {
+ my $cmd = shift @ARGV;
+ if( $cmd eq '-a' ) {
+ my $lastid = undef;
+ foreach( @{$tables->query( 'allrights', [] )} ) {
+ my( $id, $name, $mail, $rid ) = @{$_};
+ if( $id != $lastid ) {
+ print "$mail ($id)\t$name\n";
+ $lastid = $id;
+ }
+ print " $privnames->{$rid} ($rid)\n";
+ }
+ } elsif( $cmd =~ /^[+-]l?$/ ) {
+ my $user = shift @ARGV;
+ my $id = $tables->query( 'getId', [ $user, $user ] )->[ 0 ]->[ 0 ];
+ die "Invalid user $user\n" unless( defined $id );
+ my $right = $privnums->{shift @ARGV};
+ die "Invalid right $right\n" unless( defined $right );
+ my @params = ( $id, $right );
+ my $q = ( $cmd =~ /-/ ) ? 'del' : 'add';
+ $tables->command( $q, \@params );
+ } elsif( $cmd eq '-h' ) {
+ print "rights.pl username\t\t\tPrint user's rights\n";
+ print "rights.pl -a\t\t\t\tPrint all users and their rights\n";
+ print "rights.pl +/- user right\t\tGrant/revoke user's right\n";
+ } else {
+ print "$cmd\n";
+ userRights( $tables, $cmd );
+ }
+}
+$dbh->commit();
+$dbh->disconnect();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::DBQ;
+use PciIds::Db;
+use PciIds::Notifications;
+use PciIds::Xmpp;
+
+my $dbh = connectDb();
+my $tables = PciIds::DBQ::new( $dbh );
+
+sendNotifs( $tables );
+flushXmpp();
+$tables->commit();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+BEGIN {
+ unshift @INC, ".";
+}
+use PciIds::Db;
+use PciIds::Config;
+use DBI;
+
+my( $orig ) = @ARGV;
+my $newdb = connectDb();
+my( $user, $passwd ) = confList( [ "dbuser", "dbpasswd" ] );
+my $olddb = DBI->connect( "dbi:mysql:$orig", $user, $passwd, { 'RaiseError' => 1 } );
+
+print "Submiting ordinary users\n";
+my $uquery = $olddb->prepare( "SELECT DISTINCT author FROM ids WHERE author like '%@%'" );
+my $upush = $newdb->prepare( "INSERT INTO users (email, passwd) VALUES (?, '')" );
+$uquery->execute();
+my %users = ( '' => undef );
+
+while( my( $author ) = $uquery->fetchrow_array ) {
+ $upush->execute( $author );
+ $users{$author} = $newdb->last_insert_id( undef, undef, undef, undef );
+}
+
+my $clean = $newdb->prepare( "DELETE FROM locations WHERE id like 'PC/%'" );
+print "Cleaning old PCI devices to make place for new ones\n";
+$clean->execute();
+print "Submiting items from database\n";
+
+my $itemq = $olddb->prepare( "SELECT id, name, comment, author, status, type FROM ids ORDER BY LENGTH(id), id" );
+my $itemp = $newdb->prepare( "INSERT INTO locations (id, parent) VALUES (?, ?)" );
+my $comp = $newdb->prepare( "INSERT INTO history (owner, location, nodename, nodedescription, seen, time) VALUES (?, ?, ?, ?, ?, '2000-01-01 00:00:00')" );
+my $setMain = $newdb->prepare( 'UPDATE locations SET
+ maincomment = ?,
+ name = ( SELECT nodename FROM history WHERE id = ? ),
+ description = ( SELECT nodedescription FROM history WHERE id = ? )
+ WHERE
+ id = ?' );
+
+my %rex = (
+ 'v' => sub {
+ my $i = shift;
+ "PC/$i";
+ },
+ 'd' => sub {
+ my $i = shift;
+ $i =~ s/(.{4,4})(.*)/PC\/$1\/$2/;
+ return $i;
+ },
+ 's' => sub {
+ my $i = shift;
+ $i =~ s/(.{4,4})(.{4,4})(.*)/PC\/$1\/$2\/$3/;
+ return $i;
+ }
+);
+
+$itemq->execute();
+while( my( $id, $name, $description, $author, $status, $type ) = $itemq->fetchrow_array ) {
+ $id = &{$rex{$type}}( $id );
+ my $parent = $id;
+ $parent =~ s/\/[^\/]+$//;
+ eval {#Add it if not present yet
+ $itemp->execute( $id, $parent );
+ };
+ $author = '' unless( defined $author );
+ $comp->execute( $users{$author} ? $users{$author} : undef, $id, $name, $description, !$status );
+ unless( $status ) {
+ my $last = $newdb->last_insert_id( undef, undef, undef, undef );
+ $setMain->execute( $last, $last, $last, $id );
+ }
+}
+
+$newdb->commit();
+$newdb->disconnect();
--- /dev/null
+.menu, .navigation
+{
+ overflow: hidden;
+ display: none;
+}
+.author, .time
+{
+ font-style: italic;
+}
+.itemname, .name
+{
+ font-weight: bold;
+}
+.itemdescription, .description
+{
+ font-style: italic;
+ font-weight: bold;
+}
+.unnamedItem
+{
+ font-style: italic;
+}
+.comment, .unseen-comment, .main-comment
+{
+ border-bottom: dotted;
+ border-bottom-width: 1px;
+}
--- /dev/null
+body
+{
+ color: black;
+ background: #DDDDFF;
+}
+.unnamedItem, .unseen-comment
+{
+ background: #D5D5D5;
+}
+.item, .comment
+{
+ background: #F0F0F0;
+}
+.main-comment
+{
+ background: #DDFFDD;
+}
+.itemname, .name
+{
+ font-weight: bold;
+}
+.itemdescription, .description
+{
+ font-weight: bold;
+ font-style: italic;
+}
+.error
+{
+ font-weight: bold;
+ color: red;
+}
+.author, .time
+{
+ font-style: italic;
+ color: #444444;
+}
+.discussion div p, .admin div p
+{
+ padding-left: 5px;
+ padding-right: 5px;
+}
+.menu ul
+{
+ list-style-type: none;
+}
--- /dev/null
+@users
+#Each row represents a registered user, with privileges or without
+id INT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE PRIMARY KEY,#Internal ID
+email VARCHAR(255) <<CHARSET>> UNIQUE NOT NULL,#His email for notifications
+xmpp TEXT <<CHARSET>>,#His XMPP address for notifications
+login VARCHAR(50) <<CHARSET>> UNIQUE,#Login name
+passwd VARCHAR(22) <<CHARSET>> NOT NULL,#Password hash
+lastlog TEXT <<CHARSET>>,#Where did he logged in last time?
+logtime TIMESTAMP,#When did he log in last time?
+mailgather INT UNSIGNED NOT NULL DEFAULT 240,#How long to gather mail notifications before sending?
+xmppgather INT UNSIGNED NOT NULL DEFAULT 15,#How long to gather xmpp notifications before sending?
+nextmail TIMESTAMP,#When do we send pending email notifications next time?
+nextxmpp TIMESTAMP#When do we send pending xmpp notifications?
+
+@locations
+#The locations are saved in a tree. ID of the location is created by
+#appending the local IDs of the nodes on the path together (children of
+#the root first), separated by '/'. Each node must know, how long are
+#the local IDs of its children.
+#
+#(Note that the local IDs can contain '/', since it can be recognized
+#by its length.)
+#
+#The first part is 2-letter specifier of information type. The first
+#version has these:
+#PC: PCI ID
+#PD: PCI Device Class
+#
+id VARCHAR(50) <<CHARSET>> NOT NULL UNIQUE PRIMARY KEY,#The name of the location, must be just node, no / at the end
+parent VARCHAR(50) <<CHARSET>>,#To allow selecting of all node's children
+maincomment INT UNSIGNED,#Reference for the main comment
+name TINYTEXT <<CHARSET>>,#Should match the one of main comment, if any (if no main comment, name can be set too)
+description TEXT <<CHARSET>>,#Should match the one of main comment (if no main comment, can be set too)
+CONSTRAINT parent_ref FOREIGN KEY (parent) REFERENCES locations(id) ON DELETE CASCADE
+
+@rights
+#Which privileges the users have?
+#It contains only the users with some extra privileges, not the normal ones
+userId INT UNSIGNED NOT NULL,#Who has the privilege
+rightId INT UNSIGNED NOT NULL,#What privilege
+CONSTRAINT right_user FOREIGN KEY (userId) REFERENCES users(id) ON DELETE CASCADE,
+PRIMARY KEY (userId, rightId)
+
+@history
+#Contains the comments in the discussion
+id INT UNSIGNED NOT NULL AUTO_INCREMENT UNIQUE PRIMARY KEY,
+owner INT UNSIGNED,#Who posted it?
+location VARCHAR(50) <<CHARSET>> NOT NULL,#Where it belongs
+text TEXT <<CHARSET>>,
+time TIMESTAMP NOT NULL DEFAULT NOW(),#When this was added
+nodename TINYTEXT <<CHARSET>>,#Modification of the location name
+nodedescription TEXT <<CHARSET>>,#Modification of the location comment
+seen BOOLEAN NOT NULL DEFAULT '0', #Did some admin see this, or is it still unseen?
+CONSTRAINT history_location FOREIGN KEY (location) REFERENCES locations(id) ON DELETE CASCADE,
+CONSTRAINT history_owner FOREIGN KEY (owner) REFERENCES users(id) ON DELETE SET NULL
+
+@notifications
+#Contains hooks for notifications
+user INT UNSIGNED NOT NULL,#Who wants it
+location VARCHAR(50) <<CHARSET>> NOT NULL,#Where
+recursive BOOLEAN NOT NULL DEFAULT '0',
+type SMALLINT NOT NULL,#When to send
+#0: Comment -- When a new comment is posted
+#1: Description -- Name or comment changed
+#2: MainComment -- The main comment changed
+#All contains the less common events
+notification SMALLINT NOT NULL,
+#0: mail only
+#1: xmpp only
+#2: both
+CONSTRAINT notification_location FOREIGN KEY (location) REFERENCES locations(id) ON DELETE CASCADE,
+CONSTRAINT notification_user FOREIGN KEY (user) REFERENCES users(id) ON DELETE CASCADE,
+PRIMARY KEY (user, location)
+
+@pending
+#Contains the pending notifications
+user INT UNSIGNED NOT NULL,
+comment INT UNSIGNED NOT NULL,
+notification SMALLINT NOT NULL,
+#0: mail
+#1: xmpp
+#If a notification generates both, it splits to 2 of them
+reason SMALLINT NOT NULL,
+#0: New item
+#1: New comment
+#2: Changed main article
+CONSTRAINT pending_comment FOREIGN KEY (comment) REFERENCES history(id) ON DELETE CASCADE,
+CONSTRAINT pending_user FOREIGN KEY (user) REFERENCES users(id) ON DELETE CASCADE
projects / pciids.git / commitdiff