diff --git a/Changes b/Changes new file mode 100644 index 0000000..08df859 --- /dev/null +++ b/Changes @@ -0,0 +1,7 @@ +Revision history for Perl extension Net::Citadel. + +0.01 Mon Oct 1 09:07:58 2007 + - first, very rough cut to get something working + + + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..eea56a6 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,9 @@ +Changes +Makefile.PL +MANIFEST +README +t/test.yaml +t/00pods.t +t/01citadel.t +lib/Net/Citadel.pm +META.yml Module meta-data (added by MakeMaker) diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..08c3009 --- /dev/null +++ b/META.yml @@ -0,0 +1,11 @@ +# http://module-build.sourceforge.net/META-spec.html +#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# +name: Net-Citadel +version: 0.01 +version_from: lib/Net/Citadel.pm +installdirs: site +requires: + Config::YAML: 1.42 + +distribution_type: module +generated_by: ExtUtils::MakeMaker version 6.30_01 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..1bd8c36 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,15 @@ +use 5.008008; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. +WriteMakefile( + NAME => 'Net::Citadel', + VERSION_FROM => 'lib/Net/Citadel.pm', # finds $VERSION + PREREQ_PM => { + 'Config::YAML' => '1.42', + }, + + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'lib/Net/Citadel.pm', # retrieve abstract from module + AUTHOR => 'Robert Barta ') : ()), +); diff --git a/README b/README new file mode 100644 index 0000000..57af93a --- /dev/null +++ b/README @@ -0,0 +1,35 @@ +Net-Citadel +=========== + +This package is a first cut on supporting the Citadel application +protocol as defined in + + http://www.citadel.org/doku.php/documentation:appproto:app_proto + +At this stage the package supports only some basic functionality, but +more can be added easily. Also the API is only a first (quick) +shot. Of course, you can make it a bit more 'computer sciency'. + +INSTALLATION + +To install this module type the following: + + perl Makefile.PL + make + make test + make install + +# NOTE: Since I cannot rely on a Citadel installation to exist, the test +# will silently (and successfully) terminate if no connection to a Citadel +# server can be made. See test.yaml for configuration options and rerun +# the test(s). + +COPYRIGHT AND LICENCE + +Put the correct copyright and licence information here. + +Copyright (C) 2007 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. diff --git a/lib/Net/Citadel.pm b/lib/Net/Citadel.pm new file mode 100644 index 0000000..e6c96b3 --- /dev/null +++ b/lib/Net/Citadel.pm @@ -0,0 +1,547 @@ +package Net::Citadel; + +use strict; +use warnings; + +require Exporter; +use base qw(Exporter); + +use IO::Socket; +use Data::Dumper; + +=pod + +=head1 NAME + +Net::Citadel - Citadel.org protocol coverage + +=head1 SYNOPSIS + + 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; + +=head1 DESCRIPTION + +Citadel is a "turnkey open-source solution for email and collaboration" (this is as far as marketing +can go :-). The main component is the I. 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) 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. + +=head1 INTERFACE + +=cut + +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 + }; + +=pod + +=head2 Constructor + +The constructor creates a handle to the citadel server (and creates the TCP connection). It expects +the folloing named parameters: + +=over + +=item I (C) + +The hostname (or IP address) where the citadel server is running on. Defaults to C. + +=item I (C) + +The port there. + +=back + +The constructor will die if no connection can be established. + +=cut + +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; +} + +=pod + +=head2 Methods + +=head3 Authentication + +=over + +=item I + +I<$c>->login (I<$user>, I<$pwd>) + +Logs in this user, or will die if that fails. + +=cut + +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); +} + +=pod + +=item I + +I<$c>->logout + +Well, logs out the current user. + +=cut + +sub logout { + my $self = shift; + my $s = $self->{socket}; + + print $s "LOUT\n"; + <$s> =~ /(\d).. (.*)/ and ($1 == 2 or die $2); +} + +=pod + +=back + +=head3 Floors + +=over + +=item I + +I<@floors> = I<$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. + +=cut + +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 +} + +=pod + +=item I + +I<$c>->assert_floor (I<$floor_name>) + +Creates the floor with the name provided, or if it exists already simply returns. This only dies if +there are insufficient privileges. + +=cut + +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. +} + +=pod + +=item I + +I<$c>->retract_floor (I<$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. + +B: 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. + +=cut + +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; + } + } +} + +=pod + +=item I + +I<@rooms> = I<$c>->rooms (I<$floor_name>) + +Retrieves the rooms on that given floor. + +=cut + +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 +} + +=pod + +=back + +=head3 Rooms + +=over + +=item I + +I<$c>->assert_room (I<$floor_name>, I<$room_name>, [ I<$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 + +=over + +=item C (default: C) + +One of the constants C, C, C, C or +C. + +=item C (default: empty) + +=item C (default: empty) + +=back + +=cut + +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. + +=pod + +=item I + +I<$c>->retract_room (I<$floor_name>, I<$room_name>) + +B: Not implemented yet. + +=cut + +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. +} + +=pod + +=back + +=head3 Users + +=over + +=item I + +I<$c>->create_user (I<$username>, I<$password>) + +Tries to create a user with name and password. Fails if this user already exists (or some other +reason). + +=cut + +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 +}; + +=pod + +=item I + +I<$c>->change_user (I<$user_name>, I<$aspect> => I<$value>) + +Changes certain aspects of a user. Currently understood aspects are + +=over + +=item C (string) + +=item C (0..6, constants available) + +=back + +=cut + +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); +} + +=pod + +=item I + +I<$c>->remove_user (I<$name>) + +Removes the user (actually sets level to C). + +=cut + +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); +} + +=pod + +=back + +=head3 Miscellaneous + +=over + +=item I + +I<$c>->echo + +Tests the connection. + +=cut + +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/; +} + +=pod + +=item I