1#! /usr/bin/perl 2# 3# For now, this is a CGI using Perl. 4# 5 6use warnings; 7use strict; 8 9## User configurable settings: 10 11# What's the name of this server? 12our $servername = "Mumble & Murmur Test Server"; 13 14# Who should outgoing authentication emails be from? 15our $emailfrom = ""; 16 17# And what server should be used? 18our $emailserver = "localhost"; 19 20# Which server to add to? Unless you have multiple virtual servers, 21# this is always 1 22our $serverid = 1; 23 24## End of user configurable data 25## 26## Really. You shouldn't touch anything below this point. 27 28# If we're being run as a CGI in suexec, $HOME doesn't exist. Fake it. 29my $home = (getpwuid($<))[7]; 30 31# This needs to be done before "use Net::DBus" 32if (open(F, "$home/murmur/.dbus.sh")) { 33 while(<F>) { 34 chomp(); 35 if ($_ =~ /^(.+?)\='(.+)';$/) { 36 $ENV{$1}=$2; 37 } 38 } 39 close(F); 40} 41 42use CGI; 43use CGI::Carp 'fatalsToBrowser'; 44use CGI::Session; 45use Net::SMTP; 46use Net::DNS; 47use Net::DBus; 48use Image::Magick; 49use Compress::Zlib; 50use Config::Simple; 51 52sub randomCode($) { 53 my ($length) = @_; 54 my $ret; 55 my $chars="0123456789abcdefghjiklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; 56 57 for(my $i=0;$i<$length;$i++) { 58 $ret .= substr($chars, rand(int(length($chars))), 1); 59 } 60 return $ret; 61} 62 63my $showit = 1; 64 65CGI::Session->find( sub { } ); 66 67my $q = new CGI(); 68my $s = new CGI::Session(); 69 70$s->expire('+1d'); 71 72print $s->header(); 73print $q->start_html(-title=>"Registration"); 74 75my $bus; 76my $service; 77 78# First try the system bus 79eval { 80 $bus=Net::DBus->system(); 81 $service = $bus->get_service("net.sourceforge.mumble.murmur"); 82 83 my $cfg = new Config::Simple(filename => '/etc/mumble-server.ini', syntax => 'simple'); 84 $servername = $cfg->param("registerName") || $servername; 85 $emailfrom = $cfg->param("emailfrom") || $emailfrom; 86}; 87 88# If that failed, the session bus 89if (! $service) { 90 eval { 91 $bus = Net::DBus->session(); 92 $service = $bus->get_service("net.sourceforge.mumble.murmur"); 93 } 94} 95 96die "Murmur service not found" if (! $service); 97 98if (! defined($emailfrom) || ($emailfrom eq "")) { 99 croak(qq{Missing configuration. 100 Please edit either /etc/mumble-server.ini for systemwide installations, 101 or murmur.pl for a personal one. 102 }); 103} 104 105 106# Fetch handle to remote object 107my $object = $service->get_object("/$serverid"); 108my $res; 109 110my $auth = $q->param('auth'); 111my $name = $q->param('name'); 112my $pw = $q->param('pw'); 113my $email = $q->param('email'); 114my $image = $q->upload('image'); 115 116if (defined($s->param('auth')) && ($auth eq $s->param('auth'))) { 117 $res = $object->getRegisteredPlayers($s->param('name')); 118 if ($#{$res} == 0) { 119 my $aref = $$res[0]; 120 if ($email ne $$aref[2]) { 121 $$aref[3] = $s->param('pw'); 122 $object->updateRegistration($aref); 123 print "<h1>Updated password</h1><p>Your password has been reset.</p>"; 124 $showit = 0; 125 } else { 126 print "<h1>Apologies</h1><p>Someone has already registered that name in the meantime.</p>"; 127 } 128 } else { 129 $res = $object->registerPlayer($s->param('name')); 130 if (($res != 0) && ($res != "0")) { 131 my @array = ($res, $s->param('name'), $s->param('email'), $s->param('pw')); 132 $object->updateRegistration(\@array); 133 print "<h1>Succeeded</h1><p>Thank you for registering.</p>"; 134 $showit = 0; 135 } else { 136 print "<h1>Failed</h1><p>Username rejected by server.</p>"; 137 } 138 } 139 $s->clear(); 140} elsif (defined($name) && defined($pw) && defined($image)) { 141 my $id = $object->getPlayerIds( [ $name ] ); 142 $res = $object->verifyPassword($$id[0], $pw); 143 if (! $res) { 144 print "<h1>Tsk tsk</h1><p>Now, that's not a valid user and password, is it?</p>"; 145 } else { 146 my $blob; 147 sysread($image,$blob,1000000); 148 my $image=Image::Magick->new(); 149 my $r=$image->BlobToImage($blob); 150 if (! $r) { 151 $image->Extent(x => 0, y => 0, width => 600, height => 60, background => "transparent"); 152 my $out=$image->ImageToBlob(magick => 'rgba', depth => 8); 153 if (length($out) == (600*60*4)) { 154 # We need BGRA, AKA ARGB inverse 155 my @a=unpack("C*", $out); 156 for(my $i=0;$i<600*60;$i++) { 157 my $red=$a[$i*4]; 158 my $blue=$a[$i*4+2]; 159 $a[$i*4]=$blue; 160 $a[$i*4+2]=$red; 161 } 162 @a=unpack("C*", pack("N", $#a + 1) . compress(pack("C*",@a))); 163 $res = $object->setTexture($$id[0], \@a); 164 } else { 165 $r=1; 166 } 167 } 168 if ($r) { 169 print "<h1>Image failure</h1><p>Failed to convert that to a proper image.</p>"; 170 } else { 171 print "<h1>Succeeded</h1><p>Reconnect to use the new image.</p>"; 172 $showit = 0; 173 } 174 } 175} elsif (defined($name) && defined($pw) && defined($email)) { 176 my @errors; 177 178 if (length($name) < 4) { 179 push @errors, "Username is too short."; 180 } 181 if (length($pw) < 8) { 182 push @errors, "Password is too short."; 183 } 184 if ($name !~ /^[0-9a-zA-Z\(\)\[\]\-\_]+$/) { 185 push @errors, "Username contains illegal characters."; 186 } 187 188 if ($email !~ /^[0-9a-zA-Z\.\-\_]+\@(.+)$/) { 189 push @errors, "That doesn't even look like an email adddress."; 190 } else { 191 my @mx = mx($1); 192 if ($#mx == -1) { 193 push @errors, "And how am I supposed to send email there?"; 194 } 195 } 196 197 $res=$object->getRegisteredPlayers($name); 198 if ( $#{$res} == 0 ) { 199 my $aref = $$res[0]; 200 if ($email ne $$aref[2]) { 201 push @errors, "Name is already taken"; 202 } 203 } 204 205 if ($#errors == -1) { 206 my $code = randomCode(10); 207 208 $s->param('name', $name); 209 $s->param('pw', $pw); 210 $s->param('email', $email); 211 $s->param('auth', $code); 212 213 my $smtp = new Net::SMTP($emailserver); 214 if (! $smtp) { 215 croak(qq{Failed to connect to SMTP server "$emailserver". This is most likely a configuration problem.\n}); 216 } 217 $smtp->mail($emailfrom); 218 $smtp->to($email); 219 $smtp->data(); 220 $smtp->datasend("From: $emailfrom\n"); 221 $smtp->datasend("To: $email\n"); 222 $smtp->datasend("Subject: Murmur registration\n"); 223 $smtp->datasend("\n"); 224 $smtp->datasend("A user from $ENV{'REMOTE_ADDR'} registered the username $name\n"); 225 $smtp->datasend("on \"${servername}\".\n\n"); 226 $smtp->datasend("If this was you, please visit the following url to activate your account:\n"); 227 $q->delete_all(); 228 $q->param('auth', $code); 229 $smtp->datasend($q->url(-query=>1)); 230 $smtp->datasend("\n\n"); 231 $smtp->datasend("If you have no idea what this is about, just disregard this message."); 232 $smtp->dataend(); 233 234 print '<h1>Registration complete</h1><p>Thank you for registering. An email has been sent to you with '; 235 print 'an activation code.</p>'; 236 $showit = 0; 237 } else { 238 print '<ul>'; 239 foreach my $error (@errors) { 240 print "<li>$error</li>"; 241 } 242 print '</ul>'; 243 } 244} 245 246if ($showit) { 247 print '<h1>Registration form</h1>'; 248 print '<p>Fill out your desired username, password and your current email address. A mail will be sent to you '; 249 print 'with an authentication code.</p>'; 250 print '<p>If you\'ve forgotten your password, just reregister with the same name and email address. A new '; 251 print 'confirmation email will be sent.</p>'; 252 print '<p>'; 253 print $q->start_form(-method=>'POST'); 254 print "Username "; 255 print $q->textfield(-name=>'name', -size=>'10'); 256 print "<br />\n"; 257 print "Email "; 258 print $q->textfield(-name=>'email', -size=>'30'); 259 print "<br />\n"; 260 print "Password "; 261 print $q->password_field(-name=>'pw', -size=>'10'); 262 print "<br />\n"; 263 print $q->submit(-value=>'Register'); 264 print $q->end_form(); 265 print '</p>'; 266 267 print '<h1>Upload custom texture?</h1>'; 268 print '<p>'; 269 print 'Remember that the image must be 600 by 60 pixels, and must have an alpha channel.<br />'; 270 print "\n"; 271 print $q->start_form(-method=>'POST'); 272 print "Username "; 273 print $q->textfield(-name=>'name', -size=>'10'); 274 print "<br />\n"; 275 print "Password "; 276 print $q->password_field(-name=>'pw', -size=>'10'); 277 print "<br />\n"; 278 print "Image "; 279 print $q->filefield(-name=>'image', -size=>'30'); 280 print "<br />\n"; 281 print $q->submit(-value=>'Upload Image'); 282 print $q->end_form(); 283 print '</p>'; 284} 285 286print $q->end_html(); 287