#
# cheap RVP server implementation.
#
# Bolting this onto your Apache server:
# PerlSwitches -I/path/to/RVP/module
# <Location /instmsg>
#         PerlHeaderParserHandler RVP
# </Location>
#
# You also require a mysql database; the schemas required are at the
# end of this script.
#
# Main TODO item:
# * implement ACL controls.
# most of this works pretty well
# * polling would be good
package RVP;

use strict;
use warnings;

use DBI;
use DBD::mysql;
use Data::Dumper;
use XML::Simple;
use XML::LibXML;
use URI;
use LWP::UserAgent; # hmm

# I HATE MOD_PERL "COMPATIBILITY"
BEGIN {
    eval <<"EOC";
use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::RequestUtil ();
use Apache2::ServerUtil ();
use Apache2::ServerRec ();
use Apache2::Process ();
use Apache2::Const;
use Apache2::Log;
use APR::Table ();
use Apache2::Reload;

use APR::Brigade ();
use APR::Bucket ();
use Apache2::Connection;
use Apache2::Filter;

use Apache2::Const -compile => qw(MODE_READBYTES);
use APR::Const    -compile => qw(SUCCESS BLOCK_READ);

package Apache;
sub OK { Apache2::Const::OK }
sub DECLINED { Apache2::Const::DECLINED }
sub MODE_READBYTES { Apache2::Const::MODE_READBYTES }

package APR;
sub BLOCK_READ { APR::Const::BLOCK_READ }

package main;
EOC
    if ( $@ ) {
        eval <<"EOC2";
use Apache::RequestRec ();
use Apache::RequestIO ();
use Apache::RequestUtil ();
use Apache::ServerUtil ();
use Apache::ServerRec ();
use Apache::Process ();
use Apache::Const;
use Apache::Log;
use APR::Table ();
use Apache::Reload;
use Apache::Const -compile => qw(MODE_READBYTES);
use APR::Const    -compile => qw(SUCCESS BLOCK_READ);
use APR::Brigade ();
use APR::Bucket ();
use Apache::Connection;
use Apache::Filter;
EOC2
        if ( $@ ) {
            die $@;
        }
    }
}

# ACL /instmsg/aliases/<myusername> HTTP/1.1
# NOTIFY /instmsg/aliases/<otheruser> HTTP/1.1
# PROPFIND /instmsg/aliases/<myusername> HTTP/1.1
# PROPPATCH /instmsg/aliases/<myusername> HTTP/1.1
# PROPPATCH /instmsg/local/<server>/instmsg/aliases/<myusername> HTTP/1.1
# SUBSCRIBE /instmsg/aliases/<myusername> HTTP/1.1
# SUBSCRIBE /instmsg/aliases/<otheruser> HTTP/1.1
# SUBSCRIPTIONS /instmsg/aliases/<myusername> HTTP/1.1
# UNSUBSCRIBE /instmsg/local/<server>/instmsg/aliases/<myusername> HTTP/1.1
my %methods = (
               ACL => \&handle_acl,
               NOTIFY => \&handle_notify,
               PROPFIND => \&handle_propfind,
               PROPPATCH => \&handle_proppatch,
               SUBSCRIBE => \&handle_subscribe,
               SUBSCRIPTIONS => \&handle_subscriptions,
               UNSUBSCRIBE => \&handle_unsubscribe,

               # undocumented. yay.
               POLL => \&handle_poll,

               GET => \&handle_get,
               HEAD => \&handle_501,
               POST => \&handle_501,
               PUT => \&handle_501,
               LOCK => \&handle_501,
               UNLOCK => \&handle_501,
               OPTIONS => \&handle_501,


               COPY => \&handle_405,
               MOVE => \&handle_405,
              );

# DBI::apache automatically turns this lot into shared connections.
sub getdbh {
    # this env setting keeps getting lost.
    $ENV{DBI_DSN} = "dbi:mysql:database=rvp:host=db;user=rvp;password=rvp";
    my $dbh = DBI->connect( "dbi:mysql:database=rvp;host=db", "rvp",
                            "rvp" );
    expire_stuff( $dbh );
    return $dbh;
}

sub ungetdbh {
    my $dbh = shift;

    if ( !defined( $dbh )) {
        print STDERR "disconnecting undef\n";
        return;
    }
    $dbh->disconnect();
}

#
# clean out any old subscriptions/views
#
sub expire_stuff {
    my $dbh = $_[0]||getdbh();

    # fixme: if we expire someone out of sight, send notifies

    $dbh->do( "DELETE from views WHERE expires < ?", undef, time());
    $dbh->do( "DELETE from subscriptions WHERE expires < ?", undef, time());
    if ( defined( $_[0] )) {
        ungetdbh( $dbh );
    }
}

sub handler {
    my $r = shift;

    # handler code comes here
    my $method = $r->method;
    if ( grep /^$method$/, keys %methods ) {
        $r->server->method_register( $r->method );
        $r->handler( "perl-script" );
        $r->push_handlers( PerlResponseHandler => $methods{$r->method} );
        return Apache::OK;
    } else {
        return Apache::DECLINED;
    }
}

#
# Handle ACL get/set
#
sub handle_acl {
    my $r = shift;
    my $content = content( $r );
    my $principal = $r->headers_in->get( 'RVP-From-Principal' );
    my $whom = $r->uri;
    my $hostname = my_fully_qualified_hostname( $r );
    my %principals;

    # canonicalise $whom
    $whom = 'http://' . $hostname . $whom;

    my $dbh = getdbh();

    # this happens regardless of which operation we're doing but we
    # shouldn't be doing it twice FIXME
    my $sth = $dbh->prepare( "SELECT * FROM acls WHERE principal=? ORDER BY apply_to" );

    my $rv = $sth->execute( $whom );
    if ( defined( $rv )) {
        while ( my $hash = $sth->fetchrow_hashref ) {
            $principals{$hash->{apply_to}} = {
                                              credentials => [],
                                              grant => [],
                                              deny => []
                                             };

            for my $a ( "assertion", "digest", "ntlm" ) {
                if ( $hash->{$a}||0 ) {
                    push @{$principals{$hash->{apply_to}}->{credentials}}, $a;
                }
            }
            for my $a ( "list", "read", "write", "send_to", "receive_from",
                        "readacl", "writeacl", "presence", "subscriptions",
                        "subscribe_others" ) {
                if ( $hash->{$a}||0 ) {
                    # yes, this is silly. damned constants.
                    my $b = $a;
                    $b =~ s/_/-/g;
                    push @{$principals{$hash->{apply_to}}->{grant}}, $b;
                }
            }
        }
    }
    $sth->finish();

    if ( !$content ) {
        # retrieve ACLs
    } else {
        # set ACLs
        eval {
            my $ref = XMLin( $content, KeepRoot => 1, ForceArray => 1,
                             KeyAttr => [] );
            for my $ace ( @{$ref->{"a:rvpacl"}->[0]->{"a:acl"}->[0]->{"a:ace"}}) {
                my $recip =
                  $ace->{'a:principal'}->[0]->{'a:rvp-principal'}->[0]
                    if defined( $ace->{'a:principal'}->[0]->{'a:rvp-principal'});
                if ( !defined( $recip )) {
                    if ( $ace->{'a:principal'}->[0]->{'a:allprincipals'}) {
                        $recip = "allprincipals";
                    } else {
                        $r->log_error( Dumper( $ace ));
                        next;
                    }
                }

                $dbh->do( "REPLACE INTO acls(principal, apply_to) VALUES(?,?)",
                          undef, $whom, $recip );

                for my $cred ( keys %{$ace->{'a:principal'}->[0]->{'a:credentials'}->[0]}) {
                    $cred =~ s/^a://;
                    $dbh->do( "UPDATE acls SET $cred=1 WHERE principal=? AND apply_to=?", undef, $whom, $recip );
                }

                my $count = 0;
                for my $grant ( keys %{$ace->{'a:grant'}->[0]}) {
                    $grant =~ s/^a://;
                    $grant =~ s/-/_/g;
                    $dbh->do( "UPDATE acls SET \`$grant\`=1 WHERE principal=? AND apply_to=?", undef, $whom, $recip );
                    $count++;
                }

                for my $deny ( keys %{$ace->{'a:deny'}->[0]}) {
                    $deny =~ s/^a://;
                    $deny =~ s/-/_/g;
                    $dbh->do( "UPDATE acls SET \`$deny\`=0 WHERE principal=? AND apply_to=?", undef, $whom, $recip );
                    $count++;
                }

                # if no acls are set, delete the entire entry
                if ( $count == 0 ) {
                    $dbh->do( "DELETE FROM acls WHERE principal=? AND apply_to=?", undef, $whom, $recip );
                }
            }
        };
        if ( $@ ) {
            $r->log_error( "ACL failed: $@" );
        }


        # requery
        %principals = ();
        my $sth = $dbh->prepare( "SELECT * FROM acls WHERE principal=? ORDER BY apply_to" );

        my $rv = $sth->execute( $whom );
        if ( defined( $rv )) {
            while ( my $hash = $sth->fetchrow_hashref ) {
                $principals{$hash->{apply_to}} = {
                                                  credentials => [],
                                                  grant => [],
                                                  deny => []
                                                 };

                for my $a ( "assertion", "digest", "ntlm" ) {
                    if ( $hash->{$a}||0 ) {
                        push @{$principals{$hash->{apply_to}}->{credentials}}, $a;
                    }
                }
                for my $a ( "list", "read", "write", "send_to", "receive_from",
                            "readacl", "writeacl", "presence", "subscriptions",
                            "subscribe_others" ) {
                    if ( $hash->{$a}||0 ) {
                        # yes, this is silly. damned constants.
                        my $b = $a;
                        $b =~ s/_/-/g;
                        push @{$principals{$hash->{apply_to}}->{grant}}, $b;
                    }
                }
            }
        }
        $sth->finish();
    }
    ungetdbh( $dbh );

    # build the response
    if ( !keys %principals ) {
        # make sure we can access our own ACL stuff, at least
        $principals{$principal} = {
                                   credentials => [
#                                                   'assertion',
                                                   'digest',
                                                   'ntlm'
                                                  ],
                                   grant => [
                                             "list",
                                             "read",
                                             "write",
                                             "send-to",
                                             "receive-from",
                                             "readacl",
                                             "writeacl",
                                             "presence",
                                             "subscriptions",
                                             "subscribe-others",
                                            ],
                                   deny => [
                                           ],
                                  };

        # wtf quoting? seems like 'read' and 'write' cause parse
        # problems unless quoted.
        $dbh->do( 'INSERT INTO acls(principal,apply_to,assertion,digest,ntlm,list,`read`,`write`,send_to,receive_from,readacl,writeacl,presence,subscriptions,subscribe_others) values(?,?,0,1,1,1,1,1,1,1,1,1,1,1,1)', undef, $principal, $principal );

        # add a default principal, should probably be configurable FIXME
        $principals{allprincipals} = {
                                      credentials => [
#                                                      'assertion',
                                                      'digest',
                                                      'ntlm'
                                                     ],
                                      grant => [
                                                'list',
                                                'read',
                                                'send-to',
                                                'presence',
                                               ],
                                      deny => [
                                              ],
                                     };
        $dbh->do( 'INSERT INTO acls(principal,apply_to,assertion,digest,ntlm,list,`read`,send_to,presence) VALUES(?,?,0,1,1,1,1,1,1)', undef, $principal, "allprincipals" );
    }

    my $out = "";

    $out = "";
    $out .=<<"EOF";
<?xml version="1.0"?>
<a:rvpacl xmlns:d='DAV:' xmlns:r='http://schemas.microsoft.com/rvp/' xmlns:a='http://schemas.microsoft.com/rvp/acl/'><a:acl><a:inheritance>none</a:inheritance>
EOF
    for my $principal ( keys %principals ) {
        $out .= "<a:ace>";
        $out .= "<a:principal>";
        if ( $principal eq "allprincipals" ) {
            $out .= "<a:allprincipals/>";
        } else {
            $out .= "<a:rvp-principal>";
            $out .= $principal;
            $out .= "</a:rvp-principal>";
        }
        $out .= "<a:credentials>";
        for my $cred ( @{$principals{$principal}->{credentials}}) {
            $out .= "<a:$cred/>";
        }
        $out .= "</a:credentials>";
        $out .= "</a:principal>";
        $out .= "<a:grant>";
        for my $grant ( @{$principals{$principal}->{grant}} ) {
            $out .= "<a:$grant/>";
        }
        $out .= "</a:grant>";
        $out .= "<a:deny>";
        for my $deny ( @{$principals{$principal}->{deny}} ) {
            $out .= "<a:$deny/>";
        }
        $out .= "</a:deny>";
        $out .= "</a:ace>";
    }
    $out .= "</a:acl></a:rvpacl>";

    $r->content_type( "text/xml" );
    $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
    $r->headers_out->set( "Content-Length" => length( $out ));
    $r->print( $out );

    return Apache::OK;
}

#
# handle notifications
#
sub handle_notify {
    my $r = shift;
    my $headers_in = $r->headers_in;
    my $content = content($r);
    my $to = $r->uri;
    my $from = $r->headers_in->get( "RVP-From-Principal" );
    my $acktype = $r->headers_in->get( "RVP-Ack-Type" );
    my $hopcount = $r->headers_in->get( "RVP-Hop-Count" );
    my $rc = 200;
    my $hostname = my_fully_qualified_hostname( $r );

    if ( !defined( $from )) {
        $r->status_line( "400 No principal specified in request" );
        $r->log_error( "no principal specified in notify" );
        return 400;
    }

    my $dbh = getdbh();

    # see if the intended user is online
    my $sth = $dbh->prepare( "SELECT url FROM subscriptions WHERE principal=? AND (subscribee IS NULL OR subscribee = '')" );
    $sth->execute( "http://" . $hostname . $to );
    while ( my $hash = $sth->fetchrow_hashref ) {
        my $callback = $hash->{url};
        if ( defined( $callback )) {
            $rc = send_notify( $callback, $from, $to, $content, $r );
        } else {
            $rc = 404;
        }
        if ( $rc == 404 or $rc == 500 ) {
            if ( defined( $callback )) {
                $r->log_error( "$to is not reachable, deleting callback URL" );
                $dbh->do( "DELETE FROM subscriptions WHERE principal=? AND url=?", undef, "http://" . $hostname . $to, $callback );
            } else {
                $r->log_error( "no callback defined for $to" );
            }
        } elsif ( $rc != 200 ) {
            $r->log_error( "$to return code $rc" );
        }
    }
    $sth->finish();
    ungetdbh( $dbh );

    $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
    $r->content_type('text/html');

    my $principal = new URI( $from );
    $principal = sprintf( "http://%s%s", $principal->host, $to ); # xxx port
    my $response;
    $r->status( $rc );
    if ( $rc == 200 ) {
        $response =<<"EOF";
<HTML><HEAD><TITLE>Successful</TITLE></HEAD><BODY><H2>Success 200 (Successful)</H2><HR>Notify on node $principal succeeded<HR></BODY></HTML>
EOF
    } else {
        $response =<<"EOF";
<HTML><HEAD><TITLE>Error</TITLE></HEAD><BODY><H2>Error $rc</H2><HR>Notify on node $principal failed<HR></BDOY></HTML>
EOF
    }
    $r->headers_out->set( "Content-Length" => length( $response ));
    $r->print( $response );

    return $rc;
}

#
# request a property
#
sub handle_propfind {
    my $r = shift;
    my $content = content( $r );

    if ( !( $content||"" )) {
        $r->log_error( "no content in propfind" );
        return 400;
    }

    my $url = $r->headers_in->get( 'RVP-From-Principal' );
    my ( $whom ) = $r->uri =~ m|.*/aliases/(.*)|;

    eval {
        my $ref =
          XMLin( $content, KeepRoot => 1, ForceArray => 1, KeyAttr => [] );

        my $props = $ref->{"d:propfind"}->[0]->{"d:prop"};
        my @found;

        for my $prop ( @{$props} ) {
            if ((keys %{$prop})[0] eq "d:displayname" ) {
                push @found, {
                              "d:displayname" => [
                                                  $whom
                                                 ],
                             };
            }
        }

        my $status = "HTTP/1.1 200 Successful";
        my $out = multistatus( $url, { 'd:prop' => \@found,
                                       "d:status" => [ $status ]} );

        $r->content_type( "text/xml" );
        $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
        $r->headers_out->set( "Content-Length" => length( $out ));
        $r->print( $out );
    };
    if ( $@ ) {
        $r->log_error( $@ );
        $r->status_line( "500 $@" );
        return 500;
    }
    $r->status( 207 );
    return Apache::OK;
}

#
# Handle property change
#
sub handle_proppatch {
    my $r = shift;
    my $hostname = $r->server->server_hostname;
    my $content = content( $r );
    my $principal = $r->headers_in->get( 'RVP-From-Principal' );
    my $whom = $r->uri;
    my $subscr = $r->headers_in->get( 'Subscription-Id' );

    if ( !defined( $principal )) {
        $r->log_error( "no principal set in proppatch" );
        return 400;
    }

    if ( !$content ) {
        $r->log_error( "no content in proppatch" );
        return 400;
    }

    my $dbh = getdbh();
    my $props;
    my $state;

    eval {
        # This dies on invalid input; our handler will catch that and
        # signal a 500 error.
        my $ref =
          XMLin( $content, KeepRoot => 1, ForceArray => 1, KeyAttr => [] );

        # XXX may be more than one prop to set!
        $props = $ref->{"d:propertyupdate"}->[0]->{"d:set"}->[0];
        for my $prop ( @{$ref->{"d:propertyupdate"}->[0]->{"d:set"}} ) {
            # XXX
            # Parse props here
            eval {
                if ( defined( $prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:leased-value"}->[0]->{"r:value"} )) {
                    $state =
                      (keys %{$prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:leased-value"}->[0]->{"r:value"}->[0]})[0];
                }
                $state ||= ( keys %{$prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:leased-value"}->[0]->{"r:default-value"}->[0]})[0];
            };
            $r->log_error( "propatch: $@" ) if $@;

            my $viewid = 0;
            my $timeout = 0;
            eval {
                $viewid =
                  $prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:view-id"}->[ 0 ];
            };
            $r->log_error( "proppatch: $@" ) if $@;

            eval {
                $timeout =
                  $prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:leased-value"}->[0]->{"d:timeout"}->[0];

                $timeout ||= 14400;
                $timeout += time;
            };
            $r->log_error( "proppatch: $@" ) if $@;

            # urgh
            $r->log_error( "no state found, defaulting to offline" )
              unless $state;
            $state ||= "r:offline";
            $state =~ s/^r://;

            $r->log_error( "setting $principal to $state" );

            if ( !$viewid ) {
                $dbh->do( "INSERT INTO views(principal,expires,state) VALUES(?,?,?)", undef, $principal, $timeout, $state );
                my $s = $dbh->prepare( "SELECT viewid FROM views WHERE principal=? AND expires=?" );
                my $r = $s->execute( $principal, $timeout );
                ( $viewid ) = $s->fetchrow_array();
            } else {
                $dbh->do( "UPDATE views SET expires=?, state=? WHERE viewid=?",
                          undef, $timeout, $state, $viewid );
            }

            # XXX don't set this unless we ARE successful, plus if
            # there are multiple props it should probably get set
            # multiple times...
            my $status = "HTTP/1.1 200 Successful";

            # FIXME XXX HONK
            $prop->{"d:prop"}->[0]->{"r:state"}->[0]->{"r:view-id"} = [ $viewid ];
            $prop->{"d:status"} = [ $status ];
        }

        my $out = multistatus( $principal, $props  );
        $r->content_type( "text/xml" );
        $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
        $r->headers_out->set( "Content-Length" => length( $out ));
        $r->print( $out );
    };

    if ( $@ ) {
        $r->log_error( $@ );
        $r->status_line( "500 $@" );
        ungetdbh( $dbh );
        return 500;
    }

    # notify anyone who's subscribed to me
    my $sth = $dbh->prepare( "SELECT DISTINCT principal FROM subscriptions WHERE subscribee=?" );
    my $sth2 = $dbh->prepare( "SELECT url FROM subscriptions WHERE principal=? AND (subscribee IS NULL OR subscribee = '')" );
    $sth->execute( $principal );
    while ( my $hash = $sth->fetchrow_hashref ) {
        next unless $hash->{principal};
        $sth2->execute( $hash->{principal});
        while ( my $hash2 = $sth2->fetchrow_hashref ) {
            next unless $hash2->{url};
            notify_propchange( $principal, $hash->{principal}, $hash2->{url},
                               $state, $r );
        }
        $sth2->finish();
    }
    $sth->finish();

    ungetdbh( $dbh );

    $r->status( 207 );
    return Apache::OK;
}

#
# Handle a subscription request
#
sub handle_subscribe {
    my $r = shift;
    my $headers_in = $r->headers_in;
    my $content = content($r);
    my $type = $r->headers_in->get( 'Notification-Type' );
    my $uri = $r->uri;
    my $principal = $r->headers_in->get( "RVP-From-Principal" );
    my $hostname = my_fully_qualified_hostname( $r );
    my $subscr = $r->headers_in->get( "Subscription-Id" );
    my $callback = $r->headers_in->get( "Call-Back" );
    my $lifetime = $r->headers_in->get( "Subscription-Lifetime" )||14400;

    if ( $headers_in->get( 'Host' ) ne $hostname ) {
        $r->log_error( "redirecting to $hostname" );
        $r->status_line( "302 Object Moved" );
        $r->headers_out->set( "Location" =>
                              "http://" . $hostname . $uri );
        return 302;
    }

	my $expires = $lifetime + time;

    my $dbh = getdbh();
    if ( defined( $subscr )) {
        my $sth = $dbh->prepare( "SELECT principal,url,subscribee FROM subscriptions WHERE subscription=?" );
        $sth->execute( $subscr );
        while ( my $hash = $sth->fetchrow_hashref()) {
            if ( !($hash->{subscribee}||0) ) {
                if ( "http://" . $hostname . $uri ne $hash->{principal} ) {
                    $r->status_line( "412 Precondition failed" );
                    $r->log_error( "Tried to subscribe myself with the wrong URI: wanted " . $hash->{principal} . ", got http://" . $hostname . $uri );
                    ungetdbh( $dbh );
                    return 412;
                }
                $type = "pragma/notify";
                $principal = $hash->{principal};
                $callback = $hash->{url};
                last;
            } else {
                $type = "update/propchange";
                $principal = $hash->{principal};
                $callback = $hash->{url};
                last;
            }
        }
    }

    if ( !defined( $principal )) {
        $r->status_line( "400 No principal specified in request" );
        $r->log_error( "no principal specified in subscribe" );
        ungetdbh( $dbh );
        return 400;
    }

    if ( !defined( $type )) {
        $r->status_line( "400 Subscription type not specified" );
        $r->log_error( "no type specified in subscribe for $principal" );
        ungetdbh( $dbh );
        return 400;
    }

    if ( $callback =~ /:0$ /) {
        $r->status_line( "400 Invalid callback port" );
        $r->log_error( "Invalid port specified in callback" );
        return 400;
    }

    # we don't actually use this at the moment
    my $authuser = $r->user();

    my $subid;
    if ( defined( $subscr )) {
        $subid = $subscr;
    } else {
        $dbh->do( "INSERT INTO subscriptions(principal,url,subscribee,expires) VALUES(?,?,?,?)", undef, $principal, "", "", $expires );
        $subid = $dbh->last_insert_id( undef, undef, undef, undef );
        $subid ||= $dbh->{mysql_insertid};
        # oh the hatred
        if ( !defined( $subid )) {
            my $s = $dbh->prepare( "SELECT subscription FROM subscriptions WHERE principal=? AND url='' AND expires=?" );
            my $res = $s->execute( $principal, $expires );
            ( $subid ) = $s->fetchrow_array();
        }
    }

    if ( !defined( $subid )) {
		$r->log_error( "failed to generate a subid" );
        return 500;
    }

    $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
    $r->headers_out->set( "Subscription-Id" => $subid );
    $r->headers_out->set( "Subscription-Lifetime" => $lifetime );

    my ( $user ) = $uri =~ m|/([^/]+)$|;
    my ( $href ) = $principal =~ m|(http://[^/]+)/|;
    $href .= "/instmsg/aliases/$user";

    # SUBSCRIBE handles both buddy lists and logins via the
    # Notification-Type header.

    # This is a login
    if ( $type eq "pragma/notify" ) {
        if ( $dbh->do( "SELECT subscription FROM subscriptions WHERE subscription=?", undef, $subid )) {
            $dbh->do( "UPDATE subscriptions SET principal=?, url=?, subscribee=?, expires=? WHERE subscription=?", undef, $principal, $callback, "", $expires, $subid );
        } else {
            $dbh->do( "INSERT INTO subscriptions( subscription, principal, url, subscribee, expires ) VALUES( ?,?,?,?,? )", undef, $subid, $principal, $callback, "", $expires );
        }

        $r->content_type( "text/html" );
        my $response =<<"EOF";
<HTML><HEAD><TITLE>Successful</TITLE></HEAD><BODY><H2>Success 200 (Successful)</H2><HR>SUBSCRIBE on node $principal succeeded<HR></BODY></HTML>
EOF
        $r->headers_out->set( "Content-Length" => length( $response ));
        $r->print( $response );
        $r->status( 200 );

        # And this is a buddy-list request
    } elsif ( $type eq "update/propchange" ) {

        # do we know the user? since we're authing against a PDC, yes
        # we do. We don't know much about the user, though.
        my $state = "r:offline";

        # hurrah!
        my $userinfo = `/usr/bin/wbinfo -i $user 2>/dev/null`;
        my ( @bits ) = split( ':', $userinfo );

        my $displayname = $user;
        if ( @bits ) {
            $displayname = $bits[4];
        }
        my $email = $user . '@' . my_fully_qualified_hostname( $r );

        my $sth = $dbh->prepare( "SELECT state FROM views WHERE principal=?" );
        $sth->execute( "http://" . $hostname . $uri );
        while ( my $hash = $sth->fetchrow_hashref()) {
            # attempt to consolidate more than one state: any state
            # other than offline trumps offline.
            if ( $state eq "r:offline" ) {
                $state = "r:" . $hash->{state};
            } else {
                # any online trumps any other state
                if ( $state ne "r:online" ) {
                    $state = $hash->{state};
                }
            }
        }
        $sth->finish();

        my $props = {
                     "d:prop" => [
                                  {
                                   "r:state" => [ $state ],
                                  },
                                  {
                                   "d:displayname" => [ $displayname ],
                                  },
                                  {
                                   "r:email" => [ $email ],
                                  },
                                 ],
                     "d:status" => [ "HTTP/1.1 200 Successful" ],
                    };

        if ( $dbh->do( "SELECT subscription FROM subscriptions WHERE subscription=?", undef, $subid )) {
            $dbh->do( "UPDATE subscriptions SET principal=?, url=?, subscribee=?, expires=? WHERE subscription=?", undef, $principal, $callback||"", "http://" . $hostname . $uri, $expires, $subid );
        } else {
            $dbh->do( "INSERT INTO subscriptions(subscription, principal, url, subscribee, expires ) VALUES( ?,?,?,?,? )", undef, $subid, $principal, $callback||"",
                      "http://" . $hostname . $uri, $expires );
        }

        if ( !defined( $subscr )) {
            my $response = multistatus( $href, $props );
            $r->content_type( "text/xml" );
            $r->headers_out->set( "Content-Length" => length( $response ));
            $r->print( $response );
            $r->status( 207 );
        } else {
            $r->content_type( "text/html" );
            my $response = "<p>Dude!</p>";
            $r->headers_out->set( "Content-Length" => length( $response ));
            $r->print( $response );
            $r->status( 200 );
        }
    } else {
        $r->status_line( "400 Unknown subscribe type $type" );
        $r->log_error( "unknown subscription type $type in subscribe" );
        $r->status( 400 );
    }

    ungetdbh( $dbh );

    return Apache::OK;
}

sub handle_poll {
    my $r = shift;
    my $content = content( $r );

    $r->log_error( "POLL received, data:" );
    $r->log_error( $content );

    return Apache::OK;
}

sub handle_subscriptions {
    my $r = shift;
    my $hostname = $r->server->server_hostname;
    my $user = $r->headers_in->get( 'RVP-From-Principal' );
    my ( $whom ) = $r->uri =~ m|.*/aliases/(.*)|;
    my $type = $r->headers_in->get( 'Notification-Type' );

    return 400 unless $type;
    return 400 unless $type =~ m{(update/propchange|pragma/notify)};#};

    my $dbh = getdbh();
    my $sth = $dbh->prepare( "SELECT subscription,subscribee,expires FROM subscriptions WHERE principal=?" );
    $sth->execute( $whom );
    my @subs;
    while ( my $hash = $sth->fetchrow_array()) {
        if ( $type eq "update/propchange" ) {
            next unless ( $hash->{subscribee}||0 );
        } else {
            next if ( $hash->{subscribee}||0 );
        }
        my $timeout = $hash->{expires} - time;
        my $id = $hash->{subscription};
        my $sub = $hash->{subscribee};
            push @subs, <<"EOF";
<r:subscription><r:subscription-id>$id</r:subscription-id><a:principal><a:rvp-principal>$sub</a:rvp-principal></a:principal><d:href>$sub</d:href><d:timeout>$timeout</d:timeout></r:subscription>
EOF
    }
    ungetdbh( $dbh );

    my $subs = join( '', @subs );

    my $out = <<"EOF";
<r:subscriptions xmlns:d='DAV:' xmlns:r='http://schemas.microsoft.com/rvp/' xmlns:a='http://schemas.microsoft.com/rvp/acl'>$subs</r:subscriptions>
EOF
    $out =~ s/\n//; # grr

    $out = '<?xml version="1.0"?>' . "\n" . $out;

    $r->content_type( "text/xml" );
    $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );
    $r->headers_out->set( "Content-Length" => length( $out ));
    $r->print( $out );

    return Apache::OK;
}

#
# Handle unsubscribe request.
#
sub handle_unsubscribe {
    my $r = shift;
    my $uri = $r->uri;
    my $principal = $r->headers_in->get( "Principal" );
    my $subid = $r->headers_in->get( "Subscription-Id" );
    my $hostname = $r->server->server_hostname;
    # It appears that there is never any content for this.

    if ( defined( $principal )) {
        $r->log_error( "$principal unsubs from $uri" );
    } else {
        if ( !defined( $subid )) {
            $r->log_error( "uh. Can't unsubscribe without a principal or subid" );
            return 400;
        }
        my $dbh = getdbh();
        $dbh->do( "DELETE FROM subscriptions WHERE subscription=?", undef, $subid );
        ungetdbh( $dbh );
    }

    $r->headers_out->set( "RVP-Notifications-Version" => 0.2 );

    return Apache::OK;
}

sub handle_405 {
    return 405;
}

sub handle_501 {
    return 501;
}


# wholly stolen from mod_perl examples
use constant IOBUFSIZE => 8192;

sub content {
    my $r = shift;

    my $bb = APR::Brigade->new($r->pool, $r->connection->bucket_alloc);

    my $data = '';
    my $seen_eos = 0;
    do {
        $r->input_filters->get_brigade($bb, Apache::MODE_READBYTES,
                                       APR::BLOCK_READ, IOBUFSIZE);

        for (my $b = $bb->first; $b; $b = $bb->next($b)) {
            if ($b->is_eos) {
                $seen_eos++;
                last;
            }

            if ($b->read(my $buf)) {
                $data .= $buf;
            }

            $b->remove;         # optimization to reuse memory
        }
    } while (!$seen_eos);

    $bb->destroy;

    return $data;
}

#
# Return a multistatus response with a href of URL and properties PROPS
#
sub multistatus {
    my $url = shift;
    my $props = shift;

    # Dear Microsoft, you suck. Love, Waider.
    #
    # to elaborate:
    # You can't simply use XMLout to generate the reply here, because
    # the MSN client is sensitive to (at the very least) the ordering
    # of subattributes in the r:state property. Thus this giant mess
    # to force the 'correct' order.
    my $out =<<"LEADIN";
<?xml version="1.0"?>
<d:multistatus xmlns:d='DAV:' xmlns:r='http://schemas.microsoft.com/rvp/' xmlns:a='http://schemas.microsoft.com/rvp/acl/'><d:response><d:href>$url</d:href><d:propstat>
LEADIN

    chomp( $out ); # lose the trailing newline

    my $status;
    # Handle the props
    if ( defined( $props )) {
        for my $prop ( @{$props->{"d:prop"}} ) {
            $out .= "<d:prop>";
            my $propname = ( keys %{$prop} )[0];
            $out .= "<$propname>";

            my @propvals = @{$prop->{$propname}};

            # and now for the hatred
            if ( $propname eq "d:displayname" or
                 $propname eq "r:email" or
                 $propname eq "r:mobile-state" or
                 $propname eq "r:mobile-description" ) {
                $out .= $propvals[0];
            } elsif ( $propname eq "r:state" ) {
                if ( ref $propvals[0] ne "HASH" ) {
                    $out .= "<";
                    $out .= $propvals[0];
                    $out .= "/>";
                } else {
                    for my $attr ( 'r:leased-value', 'r:view-id' ) {
                        next unless defined( $propvals[0]->{$attr} );
                        $out .= "<$attr>";
                        if ( $attr eq 'r:view-id' ) {
                            $out .= $propvals[0]->{$attr}->[0];
                        } else {
                            for my $subattr ( 'r:value', 'r:default-value',
                                              'd:timeout' ) {
                                my $subattr_ref =
                                  $propvals[0]->{$attr}->[0]->{$subattr};
                                next unless defined $subattr_ref;
                                next unless ref $subattr_ref eq "ARRAY";
                                next unless defined $subattr_ref->[0];
                                my $sa_hash = $subattr_ref->[0];
#                                next unless ref $sa_hash eq "HASH";
#                                next unless keys %{$sa_hash};
                                $out .= "<$subattr>";
                                if ( $subattr eq "d:timeout" ) {
                                    $out .=
                                      ( $propvals[0]->{$attr}->[0]->{$subattr}->[0] || 0 );
                                } else {
                                    if ( ref $sa_hash eq "HASH" and
                                         keys %{$sa_hash} ) {
                                        $out .= "<" . ( keys %{$propvals[0]->{$attr}->[0]->{$subattr}->[0]})[0] . "/>";
                                    }
                                }
                                $out .= "</$subattr>";
                            }
                        }
                        $out .= "</$attr>";
                    }
                }
            } else {
                print STDERR "ERROR: don't know how to format $propname\n";
            }

            $out .= "</$propname>";
            $out .= "</d:prop>";
        }

        $status = $props->{"d:status"}->[0];
    } else {
        $status = "HTTP/1.1 500 WTF";
    }

    # trailer
    $out .=<<"LEADOUT";
<d:status>$status</d:status></d:propstat></d:response></d:multistatus>
LEADOUT

    $out;
}

# Tell someone about a propchange
sub notify_propchange {
    my ( $from, $to, $dest, $state, $r ) = @_;
    my $hostname = my_fully_qualified_hostname( $r );

    my $ua = new LWP::UserAgent();
    my $req = new HTTP::Request( "NOTIFY" => $dest );
    my $uri = new URI( $dest );

    $req->protocol( "HTTP/1.1" );
    $req->header( "RVP-Notifications-Version" => "0.2" );
    $req->header( "Host" => $uri->host );
    $req->header( "Content-Type" => "text/xml" );
    $req->header( "RVP-From-Principal" => $hostname );

    # xxx this is dubious
    my $properties = "<d:prop><r:state><$state/></r:state></d:prop>";

    # seems reasonably correct...
    $req->header( "RVP-Hop-Count" => "2" );

    my $msg =<<"MSG";
<?xml version="1.0"?>
<d:notification xmlns:d="DAV:" xmlns:r="http://schemas.microsoft.com/rvp/"><r:propnotification><r:notification-from><r:contact><d:href>$from</d:href><r:description/></r:contact></r:notification-from><r:notification-to><r:contact><d:href>$to</d:href></r:contact></r:notification-to><d:propertyupdate><d:set>$properties</d:set></d:propertyupdate></r:propnotification></d:notification>
MSG
    $req->header( "Content-Length" => length( $msg ));
    $req->content( $msg );

    my $response = $ua->request( $req );

    # this is a bit crunky.
    if ( !$response->is_success) {
#        $r->log_error( "sent:" );
#        $r->log_error( $req->as_string );
#        $r->log_error( "recv:" );
#        $r->log_error( $response->as_string );

        if ( $response->as_string =~ /Client-Warning: internal response/is ) {
            return 0;
        } else {
            return 1;
        }
    }
    return 1;
}

#
# have to send session in to this as a param because it's called with
# the session lock held!
#
sub send_notify {
    my ( $dest, $principal, $uri, $msg, $r ) = @_;
    my $u = new URI( $dest );
    my $header = "";

    my $ua = new LWP::UserAgent();
    my $req = new HTTP::Request( "NOTIFY" => $dest );
    $uri ||= "/";
    $req->uri( "rvp://" . $u->host . ":" . $u->port . $uri );
    $req->protocol( "HTTP/1.1" );
    $req->header( "RVP-Notifications-Version" => "0.2" );
    $req->header( "Content-Type" => "text/xml" );
    $req->header( "Host" => $u->host );

    $req->header( "Content-Length" => length( $msg ));
    $req->content( $msg );

    my $response = $ua->request( $req );

    # this is a bit crunky.
    if ( !$response->is_success) {
        $r->log_error( "sent:" );
        $r->log_error( $req->as_string );
        $r->log_error( "recv" );
        $r->log_error( $response->as_string );

        # fake a response, because a 500 will cause the Gaim plugin to
        # blow up right now
        return 404;
    }

    return $response->code;
}

#
# convert a principal to an email address
#
sub email_from_principal {
    my $principal = shift;
    if ( $principal =~ /local/ ) {
        $principal =~ s{^http://.*local/([^/]+)/.*/([^/]+)$}{$2\@$1};
    } else {
        $principal =~ s{^http://([^/]+)/.*/([^/]+)$}{$2\@$1};
    }

    $principal;
}

#
# diagnostic interface
#
sub handle_get {
    my $r = shift;
    my %foo;
    my $session = \%foo;
    $r->content_type( "text/html" );

    if ( $r->uri =~ /rvp.png$/ ) {
        my $img = "/usr/share/pixmaps/gaim/status/default/msn.png";
        if ( open( IMG, "<$img" )) {
            local $/ = undef;
            binmode( IMG );
            my $pic = <IMG>;
            $r->content_type( "image/png" );
            $r->headers_out->set( "Content-Length", length( $pic ));
            $r->print( $pic );
            close( IMG );
        }
        return 200;
    }

    my $page =<<"HEAD";
<html>
  <head>
    <title>RVP status page</title>
    <link rel="icon" href="/instmsg/rvp.png" type="image/png">
    <link rel="shortcut icon" href="/instmsg/rvp.png" type="image/png">
  </head>
  <body>
HEAD

    eval {
        $page .= "<table border=\"1\">";
        $page .= "<tr><td>User</td><td>subs</td></tr>\n";
        for my $user ( keys %{$session->{users}}) {
            $page .= "<tr valign=\"top\"><td>";
            $page .= email_from_principal( $user );
            $page .= "</td><td>";
            $page .= "<table border=\"1\">";
            $page .= "<tr><td>subid</td><td>sub</td><td>callback</td><td>expiry</td></tr>";
            for my $sub ( keys %{$session->{users}->{$user}->{subscriptions}}) {
                $page .= "<tr>";
                $page .= "<td>";
                $page .= $session->{users}->{$user}->{subscriptions}->{$sub}->{subid};
                $page .= "</td>";
                $page .= "<td>$sub</td>";
                $page .= "<td>";
                $page .= $session->{users}->{$user}->{subscriptions}->{$sub}->{callback}||"-";
                $page .= "</td>";
                $page .= "<td>";
                $page .= $session->{users}->{$user}->{subscriptions}->{$sub}->{expires}||"-";
                $page .= "</td>";
                $page .= "</tr>";
            }
            $page .= "</table><br>";

            $page .= "global callback @ " .
              $session->{users}->{$user}->{callback}
                if $session->{users}->{$user}->{callback};
            $page .= "<br>";

            $page .= "state: " .
              $session->{users}->{$user}->{state}
                if $session->{users}->{$user}->{state};

            $page .= "</td></tr>\n";
        }
        $page .= "</table>";
    };

    if ( $@ ) {
        $page .= "<p><pre>$@</pre></p>";
    }

    $page .= "<pre>" . Dumper( $session ) . "</pre>";

    $page .= "</body></html>";

    $r->print( $page );

    $r->status( 200 );
    return Apache::OK;
}

sub my_fully_qualified_hostname {
    my $r = shift;
    my $name = $r->server->server_hostname();

    $name;
}

# This is a horrible bunch of code to allow me to piggyback on LWP.
package LWP::Protocol::rvp;

use vars qw( @ISA );
use LWP::Protocol::http;
@ISA = qw(LWP::Protocol::http);

sub request {
    my($self, $request, @rest ) = @_;
    my $uri = $request->uri();
    $uri =~ s/^rvp/http/;
    $request->uri( $uri );
    return $self->SUPER::request( $request, @rest );
}

sub _fixup_header {
    my ( $self, $h, $url, $proxy ) = @_;
    my $return = $self->SUPER::_fixup_header( $h, $url, $proxy );

    # make sure there's no port in the Host header
    $h->init_header( 'Host' => $url->host );
    $h->init_header( 'RVP-Notifications-Version' => 0.2 );

    $return;
}

# Yumping yimminy.
package LWP::Protocol::rvp::SocketMethods;
use vars qw(@ISA);
@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);

package LWP::Protocol::rvp::Socket;
use vars qw(@ISA);
@ISA = qw(LWP::Protocol::http::SocketMethods Net::HTTP);

# need to make the URL relative
sub format_request {
    my ( $self, $method, $uri, @rest ) = @_;
    $uri =~ s|rvp://[^/]+||;
    $self->SUPER::format_request( $method, $uri, @rest );
}

package URI::rvp;
use URI::http;
use vars qw(@ISA);
@ISA = qw(URI::http);

1;

__DATA__

Database Schema: you should be able to feed this straight to mysql to
set up the database. No prepopulation is required. MySQL 4 required,
evidently.

-- MySQL dump 10.9
--
-- Host: localhost    Database: rvp
-- ------------------------------------------------------
-- Server version	4.1.16

/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;
/*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */;
/*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */;
/*!40101 SET NAMES utf8 */;
/*!40014 SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0 */;
/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;
/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */;
/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;

--
-- Current Database: `rvp`
--

CREATE DATABASE /*!32312 IF NOT EXISTS*/ `rvp` /*!40100 DEFAULT CHARACTER SET latin1 */;

USE `rvp`;

--
-- Table structure for table `acls`
--

DROP TABLE IF EXISTS `acls`;
CREATE TABLE `acls` (
  `principal` text NOT NULL,
  `apply_to` text NOT NULL,
  `assertion` tinyint(1) NOT NULL default '0',
  `digest` tinyint(1) NOT NULL default '0',
  `ntlm` tinyint(1) NOT NULL default '0',
  `list` tinyint(1) NOT NULL default '0',
  `read` tinyint(1) NOT NULL default '0',
  `write` tinyint(1) NOT NULL default '0',
  `send_to` tinyint(1) NOT NULL default '0',
  `receive_from` tinyint(1) NOT NULL default '0',
  `readacl` tinyint(1) NOT NULL default '0',
  `writeacl` tinyint(1) NOT NULL default '0',
  `presence` tinyint(1) NOT NULL default '0',
  `subscriptions` tinyint(1) NOT NULL default '0',
  `subscribe_others` tinyint(1) NOT NULL default '0',
  PRIMARY KEY  (`principal`(512),`apply_to`(512))
) ENGINE=InnoDB DEFAULT CHARSET=latin1;

--
-- Table structure for table `subscriptions`
--

DROP TABLE IF EXISTS `subscriptions`;
CREATE TABLE `subscriptions` (
  `subscription` int(11) NOT NULL auto_increment,
  `principal` text character set latin1 NOT NULL,
  `url` text character set latin1 NOT NULL,
  `subscribee` text NOT NULL,
  `expires` int(11) NOT NULL default '0',
  PRIMARY KEY  (`subscription`)
) ENGINE=InnoDB DEFAULT CHARSET=utf8 COMMENT='new RVP table';

--
-- Table structure for table `views`
--

DROP TABLE IF EXISTS `views`;
CREATE TABLE `views` (
  `viewid` int(11) NOT NULL auto_increment,
  `principal` text NOT NULL,
  `expires` int(11) NOT NULL default '0',
  `state` varchar(20) NOT NULL default '',
  PRIMARY KEY  (`viewid`)
) ENGINE=InnoDB DEFAULT CHARSET=latin1;

/*!40101 SET SQL_MODE=@OLD_SQL_MODE */;
/*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */;
/*!40014 SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS */;
/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;
/*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */;
/*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */;
/*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */;