Net::Citadel - Citadel.org protocol coverage

Net-Citadel documentation Contained in the Net-Citadel distribution.

Index

Code Index:

NAME

Top

Net::Citadel - Citadel.org protocol coverage

SYNOPSIS

Top

  use Net::Citadel;
  my $c = new Net::Citadel (host => 'citadel.example.org');
  $c->login ('Administrator', 'goodpassword');
  my @floors = $c->floors;

  eval {
     $c->assert_floor ('Level 6 (Management)');
  }; warn $@ if $@;

  $c->retract_floor ('Level 6 (Management)');

  $c->logout;

DESCRIPTION

Top

Citadel is a "turnkey open-source solution for email and collaboration" (this is as far as marketing can go :-). The main component is the citadel server. To communicate with it you can use either a web interface, or - if you have to automate things - with a protocol

   http://www.citadel.org/doku.php/documentation:appproto:start

This package tries to do a bit of abstraction (more could be done) and handles some of the protocol handling. The basic idea is that the application using the package deals with Citadel's objects: rooms, floors, users.

INTERFACE

Top

Constructor

The constructor creates a handle to the citadel server (and creates the TCP connection). It expects the following named parameters:

host (default: localhost)

The hostname (or IP address) where the citadel server is running on. Defaults to localhost.

port (default: CITADEL_PORT)

The port there.

The constructor will die if no connection can be established.

Methods

Authentication

login

$c->login ($user, $pwd)

Logs in this user, or will die if that fails.

logout

$c->logout

Well, logs out the current user.

Floors

floors

@floors = $c->floors

Retrieves a list (ARRAY) of known floors. Each entry is a hash reference with the name, the number of rooms in that floor and the index as ID. The index within the array is also the ID of the floor.

assert_floor

$c->assert_floor ($floor_name)

Creates the floor with the name provided, or if it already exists simply returns. This only dies if there are insufficient privileges.

retract_floor

$c->retract_floor ($floor_name)

Retracts a floor with this name. Dies if that fails because of insufficient privileges. Does not die if the floor did not exist.

NOTE: Citadel server (v7.20) seems to have the bug that you cannot delete an empty floor without restarting the server. Not much I can do here about that.

rooms

@rooms = $c->rooms ($floor_name)

Retrieves the rooms on that given floor.

Rooms

assert_room

$c->assert_room ($floor_name, $room_name, [ $room_attributes ])

Creates the room on the given floor. If the room already exists there, nothing else happens. If the floor does not exist, it will complain.

The optional room attributes are provided as hash with the following fields

access (default: PUBLIC)

One of the constants PUBLIC, PRIVATE, PRIVATE_PASSWORD, PRIVATE_INVITATION or PERSONAL.

password (default: empty)
default_view (default: empty)

retract_room

$c->retract_room ($floor_name, $room_name)

NOTE: Not implemented yet.

Users

create_user

$c->create_user ($username, $password)

Tries to create a user with name and password. Fails if this user already exists (or some other reason).

change_user

$c->change_user ($user_name, $aspect => $value)

Changes certain aspects of a user. Currently understood aspects are

password (string)
access_level (0..6, constants available)

remove_user

$c->remove_user ($name)

Removes the user (actually sets level to DELETED_USER).

Miscellaneous

echo

$c->echo

Tests the connection.

time

$t = $c->time

Gets the UNIX time from the server.

TODO: timezone handling

TODOs

Top

- Decent GUI using Mason + AJAX

SEE ALSO

Top

   http://www.citadel.org/doku.php/documentation:appproto:app_proto

AUTHOR

Top

Robert Barta, <drrho@cpan.org>

COPYRIGHT AND LICENSE

Top

Copyright (C) 200[78] by Robert Barta

This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available.

Net-Citadel documentation Contained in the Net-Citadel distribution. 
package Net::Citadel;

use strict;
use warnings;

require Exporter;
use base qw(Exporter);

use IO::Socket;
use Data::Dumper;


use constant {
    CITADEL_PORT => 504
};

use constant {
    LISTING_FOLLOWS => 100,
    CIT_OK          => 200,
    MORE_DATA       => 300,
    SEND_LISTING    => 400,
    ERROR           => 500,
    BINARY_FOLLOWS  => 600,
    SEND_BINARY     => 700,
    START_CHAT_MODE => 800
};

use constant {
    PUBLIC             => 0,
    PRIVATE            => 1,
    PRIVATE_PASSWORD   => 2,
    PRIVATE_INVITATION => 3,
    PERSONAL           => 4
    };


sub new {
    my $class = shift;
    my $self = bless { @_ }, $class;
    $self->{host} ||= 'localhost';
    $self->{port} ||= CITADEL_PORT;
    use IO::Socket::INET;
    $self->{socket} = IO::Socket::INET->new (PeerAddr => $self->{host},
					     PeerPort => $self->{port},
					     Proto    => 'tcp',
					     Type     => SOCK_STREAM) or die "cannot connect to $self->{host}:$self->{port} ($@)";
    my $s = $self->{socket}; <$s>; # consume banner
    return $self;
}


sub login {
    my $self = shift;
    my $user = shift;
    my $pwd  = shift;
    my $s    = $self->{socket};

    print $s "USER $user\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 3 or die $2);

    print $s "PASS $pwd\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
}


sub logout {
    my $self = shift;
    my $s    = $self->{socket};

    print $s "LOUT\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
}


sub floors {
    my $self = shift;
    my $s    = $self->{socket};

    print $s "LFLR\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 1 or die $2);

    my @floors;
    while (($_ = <$s>) !~ /^000/) {
#warn "_floors $_";
	my ($nr, $name, $nr_rooms) = /(.+)\|(.+)\|(.+)/;
	push @floors, { id => $nr, name => $name, nr_rooms => $nr_rooms };
    }
    return @floors;
#100 Known floors:
#0|Main Floor|33
#1|SecondLevel|1
#000
}


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

    my $s    = $self->{socket};
    print $s "CFLR $name|1\n";  # we really want to create it
    <$s> =~ /(\d).. (.*)/ and ($1 == 1 or $1 == 2 or $2 =~ /already exists/ or die $2);
#CFLR XXX|1
#550 This command requires Aide access.
}


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

    my @floors = $self->floors;
    for (my $i = 0; $i <= $#floors; $i++) {
	if ($floors[$i]->{name} eq $name) {
	    my $s    = $self->{socket};
	    print $s "KFLR $i|1\n";  # we really want to delete it
	    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or $2 =~ /not in use/ or die $2);
	    return;
	}
    }
}


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

    my $s    = $self->{socket};

    my @floors  = $self->floors;
#warn "looking for $name rooms ". Dumper \@floors;
    my ($floor) = grep { $_->{name} eq $name } @floors or die "no floor '$name' known";
#warn "found floor: ".Dumper $floor;

    print $s "LKRA ".$floor->{id}."\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 1 or die $2);
    my @rooms;
    while (($_ = <$s>) !~ /^000/) {
#warn "processing $_";
 	my %room;
	@room{ ('name', 'qr_flags', 'qr2_flags', 'floor', 'order', 'ua_flags', 'view', 'default', 'last_mod') } = split /\|/, $_;
 	push @rooms, \%room;
     }
     return @rooms;
#LKRA
#100 Known rooms:
#Calendar|16390|0|0|0|230|3|3|1191241353|
#Contacts|16390|0|0|0|230|2|2|1191241353|
#..
#ramsti|2|1|64|0|230|0|0|1191241691|
#000
}


sub assert_room {
    my $self    = shift;
    my $fname   = shift;
    my @floors  = $self->floors;
    my ($floor) = grep { $_->{name} eq $fname } @floors or die "no floor '$fname' known";

    my $name  = shift;
    my $attrs = shift;
    $attrs->{access}       ||= PUBLIC;
    $attrs->{password}     ||= '';
    $attrs->{default_view} ||= '';

    my $s    = $self->{socket};

    print $s "CRE8 1|$name|".
	           $attrs->{access}.'|'.
		   $attrs->{password}.'|'.
		   $floor->{id}.'|'.
		   '|'.   # no idea what this is
		   $attrs->{default_view}.'|'.
		   "\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or $2 =~ /already exists/ or die $2);
}

#CRE8 1|Bumsti|0||0|||
#200 'Bumsti' has been created.


sub retract_room {
    my $self = shift;
    my $name = shift;
    my $s    = $self->{socket};
    print $s "GOTO $name\n";
#GOTO Bumsti
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
#200 Lobby|0|0|0|2|0|0|0|1|0|0|0|0|0|0|
    print $s "KILL 1\n";
#KILL 1
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
#200 'Bumsti' deleted.
}


sub create_user {
    my $self = shift;
    my $name = shift;
    my $pwd  = shift;
    my $s    = $self->{socket};
    print $s "CREU $name|$pwd\n";
#CREU RobertBarta|xxx
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
#200 User 'RobertBarta' created and password set.
}

use constant {
    DELETED_USER   => 0,
    NEW_USER       => 1,
    PROBLEM_USER   => 2,
    LOCAL_USER     => 3,
    NETWORK_USER   => 4,
    PREFERRED_USER => 5,
    AIDE           => 6
};


sub change_user {
    my $self = shift;
    my $name = shift;
    my %changes = @_;
    my $s    = $self->{socket};

    print $s "AGUP $name\n";
#AGUP RobertBarta
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
#200 RobertBarta|ggg|10768|1|0|4|4|1191255938|0
    my %user;
    my @attrs = ('name', 'password', 'flags', 'times_called', 'messages_posted', 'access_level', 'user_number', 'timestamp', 'purge_time');
    @user{ @attrs } = split /\|/, $2;

    $user{password}     = $changes{password}     if $changes{password};
    $user{access_level} = $changes{access_level} if $changes{access_level};

    print $s "ASUP ".(join "|", @user{ @attrs })."\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
}


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

    my $s    = $self->{socket};

    print $s "AGUP $name\n";
#AGUP RobertBarta
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
#200 RobertBarta|ggg|10768|1|0|4|4|1191255938|0
    my %user;
    my @attrs = ('name', 'password', 'flags', 'times_called', 'messages_posted', 'access_level', 'user_number', 'timestamp', 'purge_time');
    @user{ @attrs } = split /\|/, $2;

    $user{access_level} = DELETED_USER;

    print $s "ASUP ".(join "|", @user{ @attrs })."\n";
    <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2);
}


sub echo {
    my $self = shift;
    my $msg  = shift;
    my $s    = $self->{socket};

    print $s "ECHO $msg\n";
    die "message not echoed ($msg)" unless <$s> =~ /2.. $msg/;
}


sub time {
    my $self = shift;
    my $s    = $self->{socket};
    print $s "TIME\n";
    die "protocol: time failed" unless <$s> =~ /2.. (.*)\|(.*)\|(.*)/;  # not sure what the others are
    return $1;
}


our $VERSION = '0.02';

1;

__END__