#!/usr/bin/perl
######################################################################
## 
## RollernetClient - client-side Rollernet API library
##
## Version 1.0, COPYRIGHT 2009, Keith Wessel - kwessel@intenex.net
##
## This library may be used to interact with the account control center
## API used by Roller Network, rollernet.us.
##
## This program may be distributed only in its entirety unless
## the written permission of the copyright holders has been
## granted.
##
## This software library is provided to you AS-IS.  NO WARRANTIES
## AND/OR CONDITIONS, EXPRESS OR IMPLIED, INCLUDING, WITHOUT LIMITATION
## REPRESENTATION WARRANTIES OR TERMS AND CONDITIONS OF MERCHANTABILITY,
## SATISFACTORY QUALITY OR FITNESS FOR A PARTICULAR PURPOSE IS PROVIDED.
##
######################################################################
use strict;

package RollernetClient;

## CONFIGURATION SETTINGS
my $rollernet_user = 'username';     #Your Rollernet account manager user name
my $rollernet_api_key = 'your_key_here'; #Your Rollernet API key
my $rollernet_api_url = "https://acc.rollernet.us/api/api.php";
my $http_timeout = 15;

# global libraries
use Switch;
use LWP::UserAgent qw( post );
use Data::Validate qw( is_integer );
use Data::Validate::Email qw( is_email_rfc822 );
use Data::Validate::Domain qw( is_domain );
use Data::Validate::IP qw( is_ipv4 is_ipv6 );

# local variables
my ($_error_msg, $_http_error, $_request_error);

######################################################################
## Recipient map methods
######################################################################
##
## rmap_add - add an email address to the recipient map
##
## Args:
##     $addr - complete email address to add to the recipient map
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub rmap_add {
    my ($self, $addr) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "email", $addr ) );

    $request = {
	"m" => "rmap",
	"a" => "add",
	"d" => $addr
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## rmap_del - remove an email address from the recipient map
##
## Args:
##     $addr - complete email address to remove from the recipient map
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub rmap_del {
    my ($self, $addr) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "email", $addr ) );

    $request = {
	"m" => "rmap",
	"a" => "del",
	"d" => $addr
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## rmap_list - retrieve the current valid user table for the specified
##     domain.
##
## Args:
##     $domain - domain of recipient map to retrieve
##
## Return:
##     Array reference to the list of rmap values, empty if error or no
##        map defined
##
######################################################################
sub rmap_list {
    my ($self, $domain) = @_;

    my ($request, $response);

    return () if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "rmap",
	"a" => "table",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return () if ( ! defined ( $response ) || $response eq 0 );

    my @list = split ( /\n/, $response );
    shift @list;
    return ([ @list ] );
}

######################################################################
##
## rmap_default_allow - set the mode of the access map of the
##        specified domain to "Default Allow".
##
## Args:
##     $domain - domain to set mode for
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub rmap_default_allow {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );
    $request = {
	"m" => "rmap",
	"a" => "allow",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## rmap_default_deny - set the mode of the access map of the
##        specified domain to "Default Deny".
##
## Args:
##     $domain - domain to set mode for
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub rmap_default_deny {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "rmap",
	"a" => "deny",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## rmap_defer - set the mode of the access map of the
##        specified domain to "Defer Incoming".
##
## Args:
##     $domain - domain to set mode for
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub rmap_defer {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "rmap",
	"a" => "defer",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}


######################################################################
## Mail domain methods
######################################################################
##
## maildom_add - Add a new domain and sets it to "Secondary MX" mode.
##
## Args:
##     $domain - domain to add
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_add {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "add",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_del - Remove a domain.
##
## Args:
##     $domain - domain to remove
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_del {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "delete",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_enable - Enable a mail domain.
##
## Args:
##     $domain - domain to enable
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_enable {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "enable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_disable - Disable a mail domain.
##
## Args:
##     $domain - domain to disable
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_disable {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "disable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_mx - Set an existing domain to "Secondary MX" mode.
##
## Args:
##     $domain - domain to set
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_mx {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "mx",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_redirect   Set an existing domain to "SMTP Redirection" mode.
##
## Args:
##     $domain - domain to redirect
##     $host - hostname of server to redirect to
##     $port - port of server to redirect to (default 25)
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_redirect {
    my ($self, $domain, $host, $port) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );
    return 0 if ( ! $self->_check_param ( "server", $host ) );
    return 0 if ( $port && ! $self->_check_param ( "port", $port ) );

    # Default mailserver port
    my $port = 25 if ( ! defined ( $port ) );
    $domain .= "|" . $host . ":" . $port;

    $request = {
	"m" => "maildomain",
	"a" => "redirect",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_hold - Set an existing domain to "Accept and Hold Messages" mode.
##
## Args:
##     $domain - domain to hold
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_hold {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "hold",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_slow_on - Turn on "slow delivery" mode for a domain.
##
## Args:
##     $domain - domain to set to slow delivery
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_slow_on {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "slowenable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## maildom_slow_off - Turn off "slow delivery" mode for a domain.
##
## Args:
##     $domain - domain to unset slow delivery
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub maildom_slow_off {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "maildomain",
	"a" => "slowdisable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}


######################################################################
## Secondary DNS methods
######################################################################
##
## dns_add - add the specified domain to secondary DNS servers
##
## Args:
##     $domain - the domain to add
##     $master - master DNS server for this domain
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_add {
    my ($self, $domain, $master) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );
    return 0 if ( ! $self->_check_param ( "server", $master ) );

    $request = {
	"m" => "dns",
	"a" => "add",
	"d" => $domain . "|" . $master
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## dns_del - remove the specified domain from secondary DNS servers
##
## Args:
##     $domain - the domain to remove
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_del {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "dns",
	"a" => "delete",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## dns_enable - enable the specified domain on secondary DNS servers
##
## Args:
##     $domain - the domain to enable
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_enable {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "dns",
	"a" => "enable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## dns_disable - disable the specified domain on secondary DNS servers
##
## Args:
##     $domain - the domain to disable
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_disable {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "dns",
	"a" => "disable",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## dns_retransfer - request a retransfer of the specified domain on all
##     DNS servers
##
## Args:
##     $domain - the domain to add
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_retransfer {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "dns",
	"a" => "retransfer",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## dns_delzone - Delete zone file for the specified domain from all
##     secondary DNS servers
##
## Args:
##     $domain - the domain to add
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub dns_delzone {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "dns",
	"a" => "delzone",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}


######################################################################
## Mail queue methods
######################################################################
##
## mailq_status - retrieve the number of messages queued on each
##     secondary MX server for the specified domain
##
## Args:
##     $domain - the domain to retrieve queue data for
##
## Return:
##     Number of messages queued on each mail server in a list, empty
##        list if an error occurred
##
######################################################################
sub mailq_status {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "mailqueue",
	"a" => "status",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return () if ( ! defined ( $response ) || $response eq 0 );
    split ( /,/, $response );
    return ( shift );
}

######################################################################
##
## mailq_status_all - retrieve the number of messages queued on each
##     secondary MX server for all domains
##
## Args:
##     None
##
## Return:
##     Hash reference with domains as keys and the number of messages
##        queued on each message server for that domain as a 
##        comma-separated string. Returns undef if an error occurred.
##
######################################################################
sub mailq_status_all {
    my ($self) = @_;

    my ($request, $response, $status_ref);

    $request = {
	"m" => "mailqueue",
	"a" => "status"
    };

    $response = $self->_send_request($request);

    return undef if ( ! defined ( $response ) || $response eq 0 );

    foreach my $line (split (/\n/, $response)) {
	my ($key, $value) = split (/,/, $line);

	$status_ref->{$key} = $value;
    }

    return $status_ref;
}

######################################################################
##
## mailq_etrn - execute an etrn for the specified domain
##
## Args:
##     $domain - the domain to etrn
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub mailq_etrn {
    my ($self, $domain) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "domain", $domain ) );

    $request = {
	"m" => "mailqueue",
	"a" => "etrn",
	"d" => $domain
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}


######################################################################
## Hosted mail box methods
######################################################################
##
## mbox_passwd - change the specify user mail box password without
##      verifying the current password first
##     secondary DNS servers
##
## Args:
##     $user - whose password to change
##     $passwd - new password
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub mbox_passwd {
    my ($self, $user, $passwd) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "email", $user ) );

    $request = {
	"m" => "mailbox",
	"a" => "passwd",
	"d[u]" => $user,
	"d[p]" => $passwd
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}

######################################################################
##
## mbox_vpasswd - change the specify user mail box password, verifying
##      the current password first
##     secondary DNS servers
##
## Args:
##     $user - whose password to change
##     $oldpasswd - current password
##     $newpasswd - new password
##
## Return:
##     1 if API returns OK, 0 if API returns ERROR, undef if
##        the API connection fails
##
######################################################################
sub mbox_vpasswd {
    my ($self, $user, $oldpasswd, $newpasswd) = @_;

    my ($request, $response);

    return 0 if ( ! $self->_check_param ( "email", $user ) );

    $request = {
	"m" => "mailbox",
	"a" => "vpasswd",
	"d[u]" => $user,
	"d[vp]" => $oldpasswd,
	"d[p]" => $newpasswd
    };

    $response = $self->_send_request($request);

    return 1 if ($response eq "OK");

    return $response;
}


######################################################################
## Error reporting
######################################################################
##
## error - return the most recent error message
##
## Args:
##     None
##
## Return:
##     Error string, undef if most recent request succeeded
##
######################################################################
sub error {
    my ($self) = @_;
    return $_error_msg;
}

######################################################################
##
## is_error - did the most recent request result in an error?
##
## Args:
##     None
##
## Return:
##     1 if most recent request resulted in an error, 0 otherwise
##
######################################################################
sub is_error {
    my ($self) = @_;
    return ( $_http_error || $_request_error );
}

######################################################################
##
## is_http_error - did the most recent request result in an
##      communications error?
##
## Args:
##     None
##
## Return:
##     1 if most recent request resulted in an HTTP error, 0 otherwise
##
######################################################################
sub is_http_error {
    my ($self) = @_;
    return $_http_error;
}

######################################################################
##
## is_request_error - did the API return an error on the most recent request?
##
## Args:
##     None
##
## Return:
##
##     1 if most recent request got back an API error, 0 otherwise
######################################################################
sub is_request_error {
    my ($self) = @_;
    return $_request_error;
}


######################################################################
## Low-level functions
######################################################################
##
## new - initialize an object and blesses itself as a member of
##     the RollernetClient class.  It also takes any variables which it wants
##     passed and puts it into the local object
##
## Args:
##     None
##
## Return:
##     $self - The blessed object refering to this package
##
######################################################################
sub new {
    my ($class) = @_;

    my $self = bless {}, $class;

    return $self;
}


######################################################################
##
## _send_request - prepares and sends a message to the server, then
##        parses the results to return to the higher level functions
##
## Args:
##     $request_ref - a hash reference containing the request, with the
##        following key-value pairs:
##        m - module
##        a - action
##        d, d[u], d[p], d[vp] - all other data necessary for the request
##
## Return:
##     $ret_string - Server response, UNDEF if no response, 0 if ERROR
##
######################################################################
sub _send_request {
    my ($self, $request_ref) = @_;

    my ($query, $ua, $req, $ret_string, $rc, $response, $ref);

    # create new user agent
    $ua = new LWP::UserAgent;
    $ua->timeout ( $http_timeout );

    # prepare the request
    $query = {
	"u" => $rollernet_user,
	"k" => $rollernet_api_key,
	%{ $request_ref }
    };

    # send it off and see what we get back
    $rc = $ua->post ( $rollernet_api_url, $query );
    
    if ( ! $rc->is_success ) {
	$_error_msg = "HTTP " . $rc->status_line;
	$_http_error = 1;
	$_request_error = 0;
	return undef;
    }

    $ret_string = $rc->content;
    chomp $ret_string;

    if ( $ret_string eq "ERROR" ) {
	$_error_msg = "API request error";
	$_http_error = 0;
	$_request_error = 1;
	return 0;
    }

    $_error_msg = undef;
    $_http_error = 0;
    $_request_error = 0;
    return $ret_string;
}

######################################################################
##
## _check_param - parameter checking for high-level methods
##
## Args:
##     $type - what type of attribute are we looking for? Supported
##        values are:
##        domain - is this a valid domain name?
##        email - is this a vlid email address?
##        server - is this a valid hostname or IP address?
##        port - is this a valid port number?
##     $data - data to check
##
## Return:
##     1 if data is valid, 0 if data is invalid
##
######################################################################
sub _check_param {
    my ($self, $type, $data) = @_;

    switch ($type) {
	case "email" {
	    if ( ! $data ) {
		$_error_msg = "No address specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	    elsif ( ! is_email_rfc822 ($data) ) {
		$_error_msg = "Invalid address specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}

	case "domain" {
	    if ( ! $data ) {
		$_error_msg = "No domain specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	    elsif ( ! is_domain ($data) ) {
		$_error_msg = "Invalid domain specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}

	case "server" {
	    if ( ! $data ) {
		$_error_msg = "No server IP or hostname specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	    elsif ( ! ( is_domain ($data) || is_ipv4 ($data) ||
		is_ipv6 ($data) ) ) {
		$_error_msg = "Invalid server IP or hostname specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}

	else {
	    if ( ! $data ) {
		$_error_msg = "Invalid server IP or hostname specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}

	case "port" {
	    if ( ! $data ) {
		$_error_msg = "No port IP or hostname specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	    elsif ( ! is_integer ($data) ) {
		$_error_msg = "Invalid port IP or hostname specified";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}

	else {
	    if ( ! $data ) {
		$_error_msg = "Missing required parameter";
		$_http_error = 0;
		$_request_error = 1;
		return 0;
	    }
	}
    }

    return 1;
}

1;