mumble/scripts/dbusauth.pl

#! /usr/bin/perl

# This is a small example script of how to set up murmur to authenticate through
# phpBB3. To use it, you'll have to have started murmur with DBus, and use the
# same session for this script.
#

use warnings;
use strict;

# Replace these with whatever is correct for you
our $dbname="phpbb3";
our $dbuser="phpbb3";
our $dbpass="uhduqw1237a";
our $dbprefix="phpbb_";
our $dbhost="localhost";

# Assign user id as phpbb3 user_id plus this, to avoid clashing
# with local murmur users. If you're going to use ONLY external
# authentication, you can set this to 1, but there's no real point.
# Note that Mumble ignores values above 1000000000 when allocating
# player IDs on its own, so you probably want to leave this alone.
our $id_offset = 1000000000;

# Path to phpBB user avatars. If you want to disable avatar support, set
# this blank. This can be either a directory path or a full URL.

our $avatar_path = "http://xeno.stud.hive.no/phpBB3/download.php?avatar=";

#
# No user servicable parts below this point.
#

use DBI;
use Net::DBus;
use Data::Dumper;
use Net::DBus::Reactor;
use LWP::UserAgent;
use Carp;

our %texturecache;

our @dbhparams=("dbi:mysql:dbname=${dbname};host=${dbhost}", $dbuser, $dbpass);
our $agent=new LWP::UserAgent;
$agent->timeout(5);

our ($bus, $service);

our $r = Net::DBus::Reactor->main;
eval {
  $bus = Net::DBus->system();
  $service = $bus->get_service("net.sourceforge.mumble.murmur");
};

if (! $service) {
  eval {
    $bus = Net::DBus->session();
    $service = $bus->get_service("net.sourceforge.mumble.murmur");
  };
}

die "Murmur service not found" if (! $service);

my $dbh=DBI->connect_cached(@dbhparams);
if (! $dbh) {
  die $DBI::errstr;
}

our $object = $service->get_object("/1");

our $rservice = $bus->export_service("net.sourceforge.mumble.phpbb");
our $robject = Mumble::Auth->new($rservice);

my $response = $object->setAuthenticator("/authority", 0);

package Mumble::Auth;

use Data::Dumper;
use Image::Magick;
use Digest::MD5 qw(md5);
use Net::DBus::Exporter qw(net.sourceforge.mumble.auther);
use base qw(Net::DBus::Object);
dbus_method("authenticate", ["string","string"], ["int32","string",["array","string"]]);
dbus_method("getUserName", ["int32"], ["string"]);
dbus_method("getUserId", ["string"], ["int32"]);
dbus_method("getUserTexture", ["int32"], [["array", "byte"]]);

sub new {
  my $class = shift;
  my $service = shift;
  my $self = $class->SUPER::new($service, "/authority");
  bless $self, $class;
  return $self;
}

sub hash {
  my $self = shift;
  my $pw = shift;
  my $hash = shift;
  my $itoa64 = './0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  my @itoa64 = split(//,$itoa64);
  my $count_log2 = index($itoa64, substr($hash,3,1));
  my $count = 1 << $count_log2;
  my $salt = substr($hash, 4, 8);

  my $nhash = $salt;

  do {
    $nhash = md5($nhash . $pw);
  } while ($count--);

  my $output = substr($hash, 0, 12);

  my $i = 0;
  my @input = split(//,$nhash);
  while ($i < 16) {
    my $value;
    $value = ord($input[$i++]);
    $output .= $itoa64[$value & 0x3f];
    if ($i < 16) {
      $value |= ord($input[$i]) << 8;
    }
    $output .= $itoa64[($value >> 6) & 0x3f];
    last if ($i++ >= 16);

    if ($i < 16) {
      $value |= ord($input[$i]) << 16;
    }
    $output .= $itoa64[($value >> 12) & 0x3f];

    last if ($i++ >= 16);
    $output .= $itoa64[($value >> 18) & 0x3f];
  };

  return $output;
}

# Possible responses are:
# >0 ID of user
# 0 SuperUser
# -1 Wrong password
# -2 Unknown user -- fall back to builtin database

sub authenticate {
  my $self = shift;
  my $uname = shift;
  my $pw = shift;

  my $dbh=DBI->connect_cached(@dbhparams);
  if (! $dbh) {
    carp $DBI::errstr;
    return -2,'',undef;
  }
  $dbh->do("SET names utf8");
  my $sth=$dbh->prepare("SELECT user_id, user_password, user_type, username FROM ${dbprefix}users WHERE LOWER(username) = LOWER(?)");
  $sth->execute($uname);
  if ((my $r=$sth->fetchrow_hashref())) {
    if ($$r{'user_password'} ne $self->hash($pw,$$r{'user_password'})) {
      print "Wrong password for $uname\n";
      return -1,'',undef;
    }
    if (($$r{'user_type'} != 0) && ($$r{'user_type'} != 3)) {
      return -1,'',undef;
    }
    my $id = $$r{'user_id'} + $id_offset;
    my $name = $$r{'username'};
    $sth->finish();

    my @groups;
    $sth=$dbh->prepare("SELECT group_name FROM ${dbprefix}user_group LEFT JOIN ${dbprefix}groups USING (group_id) WHERE user_id = ?");
    $sth->execute($$r{'user_id'});
    while ((my $g=$sth->fetchrow_hashref())) {
      push @groups, lc $$g{'group_name'};
    }
    #my $response = $object->setTemporaryGroups(0, $id, \@groups);
    #Dumper($response);
    print "Authenticated $uname as ID $id with groups ".join(" ",@groups)."\n";
    return $id,$name,\@groups;
  } else {
    print "Unknown user $uname\n";
    return -2,'',undef;
  }
}

# Possible responses are:
# string Name of user
# empty  Unknown user
# undef  Fall back to builting database

sub getUserName {
  my $self = shift;
  my $id = shift;

  my $dbh=DBI->connect_cached(@dbhparams);
  if (! $dbh) {
    carp $DBI::errstr;
    return undef;
  }
  $dbh->do("SET names utf8");
  my $sth=$dbh->prepare("SELECT username FROM ${dbprefix}users WHERE user_id = ?");
  $sth->execute($id - $id_offset);
  if ((my $r=$sth->fetchrow_hashref())) {
    print "UID $id :: " .$$r{'username'}."\n";
    return $$r{'username'};
  }
  print "No match for id $id\n";
  return undef;
}

# Same response as authenticate

sub getUserId {
  my $self = shift;
  my $name = shift;

  my $dbh=DBI->connect_cached(@dbhparams);
  if (! $dbh) {
    carp $DBI::errstr;
    return -2;
  }
  $dbh->do("SET names utf8");
  my $sth=$dbh->prepare("SELECT user_id FROM ${dbprefix}users WHERE username = ?");
  $sth->execute($name);
  if ((my $r=$sth->fetchrow_hashref())) {
    return $$r{'user_id'} + $id_offset;
  }
  return -2;
}

# Grab a user texture.

sub getUserTexture {
  my $self = shift;
  my $uid = shift;

  my @a;

  my $dbh=DBI->connect_cached(@dbhparams);
  if (! $dbh) {
    carp $DBI::errstr;
    return undef;
  }
  $dbh->do("SET names utf8");
  my $sth=$dbh->prepare("SELECT user_avatar, user_avatar_type FROM ${dbprefix}users WHERE user_id = ?");
  $sth->execute($uid - $id_offset);
  if ((my $r=$sth->fetchrow_hashref())) {
    my $file = $$r{'user_avatar'};
    my $type = $$r{'user_avatar_type'};
    if (($type != 1) && ($type != 2)) {
      print "Request for texture $uid :: not uploaded texture ($type)\n";
      return \@a;
    }
    if (exists $texturecache{$file}) {
      return $texturecache{$file};
    }

    my $url = (($type == 1) ? $avatar_path : '') . $file;
    my $response = $agent->get($url);
    if (! $response->is_success) {
      print "Request for texture $uid :: Fetch $url failed: ". $response->status_line . "\n";
    } else {
      my $image = new Image::Magick();
      my $r = $image->BlobToImage($response->content);
      if ($r) {
        print "Request for texture $uid :: Image $url load failed: $r\n";
      } else {
        $image->Extent(x => 0, y => 0, width => 600, height => 60);
        my $out=$image->ImageToBlob(magick => 'rgba', depth => 8);
        if (length($out) != (600*60*4)) {
          print "Request for texture $uid :: Failed resize\n";
        } else {
          @a = unpack("C*", $out);
          for(my $i=0;$i<600*60;$i++) {
            my $red=$a[$i*4];
            my $blue=$a[$i*4+2];
            $a[$i*4]=$blue;
            $a[$i*4+2]=$red;
          }
          print "Request for texture $uid :: $url :: Success\n";
        }
      }
    }
    $texturecache{$file} = \@a;
    return $texturecache{$file};
  }
  return undef;
}


package main;

print "Entering main DBus loop...\n";
$r->run();