digest-amqp.pl

#!/usr/bin/perl
#
#   -------------------------------------------------------------------------
#   Perl Digest-AMQP service
#
#   Syntax: digest_amqp.pl {RestMS-hostname}
#
#   This service implements the 8-Digest-AMQP@wiki.amqp.org specification.
#   It connects to the AMQP network through RestMS.  It accepts Digest-AMQP
#   requests and generates new, random passwords for each request.  The
#   passwords are reported on stdout but otherwise not stored anywhere. In
#   real use, they would need to be sent to the user somehow, e.g. by email.
#   -------------------------------------------------------------------------
#
#   Copyright (c) 1996-2009 iMatix Corporation
#
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or (at
#   your option) any later version.
#
#   This program is distributed in the hope that it will be useful, but
#   WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#   General Public License for more details.
#
#   For information on alternative licensing for OEMs, please contact
#   iMatix Corporation.

#   Modules we need to use
use LWP::UserAgent;
use HTTP::Request::Common;
use Digest::MD5;
use XML::Simple;

define_constants ();

($hostname) = @ARGV;
$hostname = "localhost:8080" unless $hostname;

$ua = new LWP::UserAgent;
$ua->agent ('Digest-AMQP/RestMS');
$ua->credentials ($hostname, "Zyre", "guest", "guest");
$ua->timeout (1);

#   Configure our messaging resources
#   Our feed is always called "Digest-AMQP", since this is where clients
#   send their requests.  We read from the feed using a pipe.  We ask the
#   server to provide us with a pipe name, which we cache between runs to
#   avoid creating multiple pipes.
#
$config_file = "digest-amqp.cfg";
$feed = feed_create ("service", "Digest-AMQP");
$pipe;
if (-f $config_file) {
    $data = eval { XMLin ($config_file) };
    $pipe = $data->{pipe};
    $pipe = pipe_create ("pipe", $pipe);
}
else {
    $pipe = pipe_create ("pipe");
    open  CONFIG, ">$config_file" || die "Can't write config file '$config_file'";
    print CONFIG "<config><pipe>$pipe</pipe></config>\n";
    close CONFIG;
}
join_create ($pipe, $feed);
carp ("I: Digest-AMQP service running at $hostname");

#   Wait for and process requests
for (;;) {
    $message = nozzle_get ($pipe, "nozzle", 0);
    $data = eval { XMLin ($message) };
    if ($@) {
        carp ("W: malformed XML request");
        exit (0);
    }
    else {
        $user = $data->{request}{user};
        $realm = $data->{request}{realm};
        $algorithm = $data->{request}{algorithm};
        $reply_to = $data->{request}{reply_to};

        #   Generate a new random password
        @chars=('a'..'z','A'..'Z','0'..'9','_');
        $password = "";
        srand;
        foreach (1..10) {
            $password .= $chars [rand @chars];
        }
        carp ("I: new password for '$user:$realm' is '$password'");
        if ($algorithm eq "MD5") {
            $digest = Digest::MD5::md5_hex("$user:$realm:$password");
        }
        elsif ($algorithm eq "SHA-1") {
            $digest = Digest::SHA::sha1_base64("$user:$realm:$password");
        }
        else {
            carp ("E: invalid algorithm '$algorithm' requested");
        }
        $xml_response = <<".";
            <digest-amqp
                xmlns="http://www.imatix.com/schema/digest-amqp"
                version="1.0">
                <response
                    user = "$user"
                    realm = "$realm"
                    algorithm = "$algorithm"
                    digest = "$digest"
                    />
            </digest-amqp>
.
        restms_post ("/$reply_to\@amq.direct", $xml_response, "application/x-Digest-AMQP");
    }
    nozzle_delete ($pipe, "nozzle");
}

#   Simple wrappers around RestMS calls
#   -------------------------------------------------------------------------
#   - create a specified feed
sub feed_create {
    my ($feed_class, $feed_name) = @_;
    restms ("PUT", "/$feed_class/$feed_name");
    return $feed_name;
}

#   - create a pipe, named by caller or by server
sub pipe_create {
    my ($pipe_class, $pipe_name) = @_;
    $pipe_class = "pipe" unless $pipe_class;
    my $response;
    if ($pipe_name) {
        $response = restms ("PUT", "/$pipe_class/$pipe_name");
    }
    else {
        $response = restms ("PUT", "/$pipe_class");
    }
    $response->content =~ /class\s*=\s*"([^"]+)"/;
    $pipe_class = $1 || die "Failed: malformed response for pipe\n";
    $response->content =~ /name\s*=\s*"([^"]+)"/;
    $pipe_name = $1 || die "Failed: malformed response for pipe\n";
    $pipe_classes {$pipe_name} = $pipe_class;
    return $pipe_name;
}

#   - create a join on a pipe, feed, and address
sub join_create {
    my ($pipe_name, $feed_name, $address) = @_;
    $pipe_class = $pipe_classes {$pipe_name} || die "No such pipe - $pipe_name\n";
    $address = "*" unless $address;
    restms ("PUT", "/$pipe_class/$pipe_name/$address\@$feed_name");
}

#   - get a message from a pipe nozzle
sub nozzle_get {
    my ($pipe_name, $nozzle, $index) = @_;
    $pipe_class = $pipe_classes {$pipe_name} || die "No such pipe - $pipe_name\n";
    my $response;
    if ($nozzle) {
        $response = restms ("GET", "/$pipe_class/$pipe_name/$nozzle/$index", 1);
    }
    else {
        $response = restms ("GET", "/$pipe_class/$pipe_name/", 1);
    }
    return $response->content;
}

#   - delete a nozzle
sub nozzle_delete {
    my ($pipe_name, $nozzle) = @_;
    $pipe_class = $pipe_classes {$pipe_name} || die "No such pipe - $pipe_name\n";
    my $response;
    if ($nozzle) {
        $response = restms ("DELETE", "/$pipe_class/$pipe_name/$nozzle");
    }
    else {
        $response = restms ("DELETE", "/$pipe_class/$pipe_name/");
    }
}

sub restms {
    my ($method, $URL) = @_;
    my $uri = "http://$hostname/restms$URL";
    #   Loop on read timeouts
    while (1) {
        my $request = HTTP::Request->new ($method => $uri);
        my $response = $ua->request ($request);
        next if $response->status_line eq "500 read timeout";
        check_response_code ("$method $uri", $response, $REPLY_OK);
        return ($response);
    }
}

sub restms_post {
    my ($URL, $content, $content_type) = @_;
    my $uri = "http://$hostname/restms$URL";
    my $request = HTTP::Request->new (POST => $uri);
    $request->content ($content);
    $request->content_type ($content_type);
    my $response = $ua->request ($request);
    check_response_code ("POST $uri", $response, $REPLY_OK);
    return ($response);
}

sub check_response_code {
    my ($request, $response, $expect) = @_;
    if ($response->code != $expect) {
        carp ($request);
        carp ("Fail: " . $response->status_line . ", expected $expect");
        carp ("Content-type=" . $response->content_type);
        carp ($response->content);
        exit (1);
    }
}

sub define_constants {
    $REPLY_OK             = 200;
    $REPLY_CREATED        = 201;
    $REPLY_ACCEPTED       = 202;
    $REPLY_NOCONTENT      = 204;
    $REPLY_PARTIAL        = 206;
    $REPLY_MOVED          = 301;
    $REPLY_FOUND          = 302;
    $REPLY_METHOD         = 303;
    $REPLY_NOTMODIFIED    = 304;
    $REPLY_BADREQUEST     = 400;
    $REPLY_UNAUTHORIZED   = 401;
    $REPLY_PAYEMENT       = 402;
    $REPLY_FORBIDDEN      = 403;
    $REPLY_NOTFOUND       = 404;
    $REPLY_PRECONDITION   = 412;
    $REPLY_TOOLARGE       = 413;
    $REPLY_INTERNALERROR  = 500;
    $REPLY_NOTIMPLEMENTED = 501;
    $REPLY_OVERLOADED     = 503;
    $REPLY_VERSIONUNSUP   = 505;
}

sub carp {
    my ($string) = @_;
    #   Prepare date and time variables
    ($sec, $min, $hour, $day, $month, $year) = localtime;
    $date = sprintf ("%04d-%02d-%02d", $year + 1900, $month + 1, $day);
    $time = sprintf ("%2d:%02d:%02d", $hour, $min, $sec);
    print "$date $time $string\n";
}