[Bps-public-commit] r15236 - in experiments/Net-CalDAV-Server: . lib/Net/CalDAV lib/Net/CalDAV/Server lib/Net/CalDAV/Server/Method
alexmv at bestpractical.com
alexmv at bestpractical.com
Mon Aug 18 15:04:01 EDT 2008
Author: alexmv
Date: Mon Aug 18 15:03:55 2008
New Revision: 15236
Added:
experiments/Net-CalDAV-Server/lib/
- copied from r13865, /experiments/Net-CalDAV-Server/lib/
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Data.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Delete.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Get.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Options.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Propfind.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Put.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Report.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Path.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Request.pm
Modified:
experiments/Net-CalDAV-Server/ (props changed)
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm
experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm
Log:
r36109 at kohr-ah: chmrr | 2008-08-18 15:03:39 -0400
* More Moose, more working -- propfinds and reports mostly work
Modified: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm
==============================================================================
--- /experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm (original)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm Mon Aug 18 15:03:55 2008
@@ -3,188 +3,67 @@
use warnings;
use strict;
-use YAML;
-use XML::Twig;
+use Net::CalDAV::Server::Data;
+use Net::CalDAV::Server::Request;
use Net::CalDAV::Server::Response;
-use Digest::MD5;
-use DateTime;
+use Net::CalDAV::Server::Method;
-use constant D => "DAV:";
-use constant C => "urn:ietf:params:xml:ns:caldav";
+use Moose;
+use MooseX::AttributeHelpers;
-use base qw/HTTP::Server::Simple Class::Accessor/;
+extends 'HTTP::Server::Simple';
-__PACKAGE__->mk_accessors(qw/header method request_uri body response/);
-
-my $PROPS = {
- "/" => {
- "D:resourcetype" => ["D:collection", "C:calendar"],
- },
-};
-
-my $DATA = {};
-
-sub namespace_for_uri {
- my $class = shift;
- my $map = {D() => "D", C() => "C"};
- return $map unless @_;
- return $map->{shift @_};
-}
-
-sub uri_for_namespace {
- my $class = shift;
- my $map = { reverse %{$class->namespace_for_uri} };
- return $map unless @_;
- return $map->{shift @_};
-}
-
-sub valid_http_method {
- my $self = shift;
- my $method = shift or return 0;
- return 1;
-}
-
-sub headers {
- my $self = shift;
- my $headers = shift;
- $self->header({});
- while ( my ( $header, $value ) = splice @$headers, 0, 2 ) {
- $self->header->{lc $header} = $value;
- }
+has request => (
+ is => 'rw',
+ isa => 'Net::CalDAV::Server::Request',
+ handles => [qw/headers/],
+);
+has response => (
+ is => 'rw',
+ isa => 'Net::CalDAV::Server::Response',
+);
+has data => (
+ is => 'rw',
+ isa => 'Net::CalDAV::Server::Data',
+ default => sub { Net::CalDAV::Server::Data->new },
+ handles => [qw/at_path/],
+);
+
+sub setup {
+ my $self = shift;
+ $self->response( Net::CalDAV::Server::Response->new );
+ $self->request( Net::CalDAV::Server::Request->new );
+ $self->request->setup( @_ );
+ $self->response->protocol($self->request->protocol);
}
-sub read_body {
- my $self = shift;
- my $body = '';
-
- my $length = $self->header->{"content-length"} || 0;
- while ($length > 0) {
- last unless sysread(STDIN, my $read, 1);
- $body .= $read;
- $length -= length $read;
- }
- $self->body($body);
-}
+sub valid_http_method { 1 }
sub handler {
- my ( $self ) = @_;
-
- warn $self->method . " " . $self->request_uri . " HTTP/1.1\n";
- warn YAML::Dump($self->header);
- $self->read_body;
- warn $self->body;
- $self->response(Net::CalDAV::Server::Response->new);
-
- my $method = "handle_" . lc $self->method;
- return $self->$method if $self->can($method);
-
- die "Boom!";
-}
-
-sub handle_options {
- my $self = shift;
- print <<EOT;
-HTTP/1.1 200 OK
-Allow: ACL, COPY, DELETE, GET, HEAD, LOCK, MKCALENDAR, MKCOL, MOVE, OPTIONS, PROPFIND, PROPPATCH, PUT, REPORT, TRACE, UNLOCK
-DAV: 1, access-control, calendar-access, calendar-schedule, calendar-availability, inbox-availability, calendar-proxy, calendarserver-private-events
-Content-Length: 0
-
-EOT
-}
-
-sub handle_propfind {
my $self = shift;
- # XXX: Depth header
- my $twig = XML::Twig->new(
- map_xmlns => $self->namespace_for_uri,
- );
- $twig->parse($self->body);
-
- my $p = $PROPS->{ $self->request_uri };
- if ( not $p ) {
- $self->response->add( $self->request_uri, 404 );
- } elsif ( $twig->find_nodes("/D:propfind/D:propname") ) {
- $self->response->add( $self->request_uri, 200, $_, undef )
- for sort keys %{$p};
- } elsif ( $twig->find_nodes("/D:propfind/D:allprop") ) {
- $self->response->add( $self->request_uri, 200, $_, $p->{$_} )
- for sort keys %{$p};
- } else {
- for my $prop ( $twig->find_nodes("/D:propfind/D:prop/*") ) {
- next unless exists $p->{ $prop->tag };
- $self->response->add( $self->request_uri, 200, $prop->tag,
- $p->{ $prop->tag } );
- }
- }
+ $self->data( Net::CalDAV::Server::Data->new )
+ unless $self->data;
- print $self->response->as_string;
-}
+ warn $self->request->as_string;
-sub handle_put {
- my $self = shift;
- # XXX: If-None-Match header
- my $now = DateTime->now;
-
- $PROPS->{$self->request_uri} ||= {};
- my $p = $PROPS->{$self->request_uri};
- my $response;
- unless (exists $DATA->{$self->request_uri}) {
- $response = HTTP::Response->new(201);
- $p->{"D:creationdate"} = $now->datetime . "Z";
- $p->{"D:getlastmodified"} = $now->strftime("%a, %d %b %Y %H:%M:%S GMT");
- } elsif ($DATA->{$self->request_uri} ne $self->body) {
- $response = HTTP::Response->new(200);
- $p->{"D:getlastmodified"} = $now->strftime("%a, %d %b %Y %H:%M:%S GMT");
- } else {
- # Unmodified
- $response = HTTP::Response->new(304);
- $response->header( "Content-Length" => 0 );
- $response->header( "ETag" => $p->{"D:getetag"} );
- print "HTTP/1.1 ".$response->as_string;
+ my $class = "Net::CalDAV::Server::Method::" . ucfirst(lc($self->request->method));
+ unless ($class->require) {
+ $self->bad_request;
return;
}
- $p->{"D:getcontentlength"} = length $self->body;
- $p->{"D:getcontenttype"} = $self->header->{"content-type"};
- $p->{"D:getetag"} = Digest::MD5::md5_base64( $self->body );
- $DATA->{$self->request_uri} = $self->body;
-
- $response->header( "Content-Length" => 0 );
- $response->header( "ETag" => $p->{"D:getetag"} );
- print "HTTP/1.1 ".$response->as_string;
-}
-sub handle_get {
- my $self = shift;
-
- unless (exists $DATA->{$self->request_uri}) {
- my $response = HTTP::Response->new(404);
- $response->header( "Content-Length" => 0 );
- print "HTTP/1.1 ".$response->as_string;
- return;
+ my $method = $class->new( server => $self);
+ if ($method->prepare) {
+ $method->run;
}
-
- my $p = $PROPS->{$self->request_uri};
-
- my $response = HTTP::Response->new(200);
- $response->header( "Content-Length", length $DATA->{$self->request_uri});
- $response->header( "Content-Type", $p->{"D:getcontenttype"});
- $response->header( "ETag", $p->{"D:getetag"});
- $response->header( "Last-Modified", $p->{"D:getlastmodified"});
- $response->content( $DATA->{$self->request_uri} );
- print "HTTP/1.1 ".$response->as_string;
+ $self->response->send;
}
-sub handle_report {
- my $self = shift;
-
- my $twig = XML::Twig->new(
- map_xmlns => $self->namespace_for_uri,
- );
- $twig->parse($self->body);
-
- return unless $twig->root->tag eq "C:calendar-query";
-
+sub authenticate {
+ return 1;
}
+#__PACKAGE__->meta->make_immutable; no Moose;
+
1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Data.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Data.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,43 @@
+package Net::CalDAV::Server::Data;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+use Net::CalDAV::Server::Path;
+
+use Data::ICal::DateTime;
+
+has paths => (
+ metaclass => 'Collection::Hash',
+ is => 'ro',
+ isa => 'HashRef[Net::CalDAV::Server::Path]',
+ default => sub { {} },
+ provides => { get => 'at_path', delete => 'delete' },
+);
+
+sub BUILD {
+ my $self = shift;
+ $self->add( "/" => props => {"D:resourcetype" => ["D:collection", "C:calendar"]});
+}
+
+sub add {
+ my $self = shift;
+ my $path = shift;
+ # XXX: Already exists?
+ my $p = $self->paths->{$path} = Net::CalDAV::Server::Path->new( path => $path, @_ );
+ return $p;
+}
+
+sub icals {
+ my $self = shift;
+ my $ical = Data::ICal->new;
+
+ return grep {$_} map {$_->ical} values %{$self->paths};
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,208 @@
+package Net::CalDAV::Server::Method;
+
+use warnings;
+use strict;
+
+use DateTime::Span;
+use DateTime::Format::ICal;
+use Data::ICal::DateTime;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+has 'server' => (
+ is => 'ro',
+ isa => 'Net::CalDAV::Server',
+ weak_ref => 1,
+ handles => [qw/authenticate at_path/],
+);
+
+has 'request' => (
+ is => 'ro',
+ isa => 'Net::CalDAV::Server::Request',
+ lazy => 1,
+ default => sub { shift->server->request },
+ handles => [qw/header uri content parse_xml/],
+);
+
+has 'response' => (
+ is => 'ro',
+ isa => 'Net::CalDAV::Server::Response',
+ lazy => 1,
+ default => sub { shift->server->response },
+ handles => [qw/send_no_auth send_precondition_failed send_not_found/],
+);
+
+sub prepare {
+ my $self = shift;
+ return 1 if not $self->protected_request;
+ return $self->check_auth;
+}
+
+sub protected_request { 1 }
+
+sub check_auth {
+ my $self = shift;
+ my $header = $self->header("Authorization");
+ return $self->send_no_auth unless $header and $header =~ /^Basic (.*?)$/;
+ my ( $user, $pass ) = split /:/, ( MIME::Base64::decode($1) || ':' ), 2;
+ return $self->send_no_auth
+ unless length $user and $self->authenticate( $user, $pass );
+ return $user;
+}
+
+sub if_match_check {
+ my $self = shift;
+ my ($path) = @_;
+ if ( my $match = $self->header("If-Match") ) {
+ return $self->send_precondition_failed unless $path;
+ if ( $match ne "*" ) {
+ my @etags = map { m{^(?:W/)?"(.*)"$} ? $1 : $_ } split /,\s*/,
+ $match;
+ return $self->send_precondition_failed
+ unless grep { $_ eq $path->etag } @etags;
+ }
+ }
+ if ( my $match = $self->header("If-None-Match") ) {
+ if ($path) {
+ return $self->send_precondition_failed if $match eq "*";
+ my @etags = map { m{^(?:W/)?"(.*)"$} ? $1 : $_ } split /,\s*/,
+ $match;
+ return $self->send_precondition_failed
+ if grep { $_ eq $path->etag } @etags;
+ }
+ }
+ return 1;
+}
+
+sub make_filter {
+ my $self = shift;
+ my $xml = shift;
+
+ if ( $xml->tag eq "C:comp-filter" ) {
+ if ( not $xml->has_children ) {
+ return sub { $_[0]->ical_entry_type eq $xml->att("name") };
+ } elsif ( $xml->has_children("C:is-not-defined") ) {
+ return sub { $_[0]->ical_entry_type ne $xml->att("name") };
+ } elsif ( $xml->has_children("C:time-range") ) {
+ my $range = $xml->first_child("C:time-range");
+ my $start = DateTime::Format::ICal->parse_datetime(
+ $range->att("start") );
+ my $end = DateTime::Format::ICal->parse_datetime(
+ $range->att("end") );
+ my $span = DateTime::Span->from_datetimes(
+ start => $start,
+ before => $end
+ );
+ return sub { $_[0]->can("is_in") and $_[0]->is_in($span) };
+ } else {
+ warn "Making comp-match filter for @{[$xml->att('name')]}";
+ my @comps = map { $self->make_filter($_) }
+ $xml->children("C:comp-filter");
+ my @props = map { $self->make_filter($_) }
+ $xml->children("C:prop-filter");
+ return sub {
+ return unless $_[0]->ical_entry_type eq $xml->att("name");
+
+ if (@comps) {
+ my $matched = 0;
+ ENTRY:
+ for my $kid ( @{ $_[0]->entries } ) {
+ for (@comps) {
+ next ENTRY unless $_->($kid);
+ }
+ $matched = 1;
+ last ENTRY;
+ }
+ return if not $matched;
+ }
+
+ for (@props) {
+ return unless $_->( $_[0] );
+ }
+
+ return 1;
+ }
+ }
+ } elsif ( $xml->tag eq "C:prop-filter" ) {
+ if ( not $xml->has_children ) {
+ return sub { defined $_[0]->property( $xml->att("name") ) };
+ } elsif ( $xml->has_children("C:is-not-defined") ) {
+ return sub { not defined $_[0]->property( $xml->att("name") ) };
+ } elsif ( $xml->has_children("C:time-range") ) {
+ warn "Time range on prop";
+ } elsif ( $xml->has_children("C:text-match") ) {
+ my $match = $xml->first_child("C:text-match");
+ if ( defined $match->att("negate-condition")
+ and $match->att("negate-condition") eq "yes" )
+ {
+ return sub {
+ return
+ unless defined $_[0]->property( $xml->att("name") );
+ return
+ if grep { index( $_, $match->text ) != -1 }
+ @{ $_[0]->property( $xml->att("name") ) };
+ return 1;
+ };
+ } else {
+ return sub {
+ return
+ unless defined $_[0]->property( $xml->att("name") );
+ return 1
+ if grep { index( $_->value, $match->text ) != -1 }
+ @{ $_[0]->property( $xml->att("name") ) };
+ return;
+ };
+ }
+ } else {
+ warn "Prop-filter with weird setup";
+ }
+ } else {
+ warn "Unknown tag: " . $xml->tag;
+ }
+ return sub { return 1 };
+}
+
+sub props {
+ my $self = shift;
+ my ( $root, $path ) = @_;
+ my $obj = (ref $path and $path->isa("Net::CalDAV::Server::Path")) ? $path : $self->at_path($path);
+ if ( not $obj ) {
+ $self->response->add( $path, 404 );
+ } elsif ( $root->find_nodes("/*/D:propname") ) {
+ $self->response->add( $path, 200, $_, undef ) for sort $obj->list;
+ } elsif ( $root->find_nodes("/*/D:allprop") ) {
+ $self->response->add( $path, 200, $_, $obj->get($_) )
+ for sort $obj->list;
+ } else {
+ my @props = $root->find_nodes("/*/D:prop/*");
+ $self->return_props( $obj, @props );
+ }
+}
+
+sub return_props {
+ my $self = shift;
+ my ( $path, @props ) = @_;
+ for my $prop (@props) {
+ if ( $prop->tag =~ /^D:/
+ and not $prop->has_children
+ and not length $prop->text )
+ {
+ next unless $path->has( $prop->tag );
+ $self->response->add( $path->path, 200, $prop->tag,
+ $path->get( $prop->tag ) );
+ } elsif ( $prop->tag eq "C:calendar-data" ) {
+
+ # XXX TODO: Actually pull out set of properties the user wants
+ my $str = $path->ical->as_string;
+ $str =~ s/\r?\n/\r\n/g;
+ $self->response->add( $path->path, 200, $prop->tag, $str );
+ } else {
+ warn "Return of @{[$prop->tag]} for @{[$path->path]}";
+ }
+ }
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Delete.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Delete.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,24 @@
+package Net::CalDAV::Server::Method::Delete;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub run {
+ my $self = shift;
+
+ my $p = $self->at_path( $self->uri );
+ return unless $self->if_match_check($p);
+ return $self->send_not_found unless $p;
+
+ $self->server->data->delete( $self->uri );
+ $self->response->code(204);
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Get.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Get.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,26 @@
+package Net::CalDAV::Server::Method::Get;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub run {
+ my $self = shift;
+
+ my $p = $self->at_path( $self->uri );
+ return $self->send_not_found unless $p;
+
+ $self->response->code(200);
+ $self->response->header( "Content-Type", $p->content_type );
+ $self->response->header( "ETag", $p->etag );
+ $self->response->header( "Last-Modified", $p->last_modified );
+ $self->response->content( $p->data );
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Options.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Options.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,30 @@
+package Net::CalDAV::Server::Method::Options;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub protected_request { 0 }
+
+sub run {
+ my $self = shift;
+ $self->response->code(200);
+ $self->response->header(
+ "Allow" => join( ", ",
+ qw/ACL DELETE GET HEAD OPTIONS PROPFIND PUT REPORT/
+ )
+ );
+ $self->response->header(
+ "DAV" => join( ", ",
+ qw/1 calendar-access calendar-schedule/
+ )
+ );
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Propfind.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Propfind.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,21 @@
+package Net::CalDAV::Server::Method::Propfind;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub run {
+ my $self = shift;
+
+ # XXX: Depth header
+ my $xml = $self->parse_xml;
+ $self->props( $xml, $self->uri );
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Put.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Put.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,35 @@
+package Net::CalDAV::Server::Method::Put;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub run {
+ my $self = shift;
+
+ my $p = $self->at_path( $self->uri );
+ if ( $p and $p->data eq $self->content ) {
+
+ # Unmodified
+ $self->response->code(304);
+ $self->response->header( "ETag" => $p->etag );
+ print $self->response->as_string;
+ return;
+ }
+
+ return unless $self->if_match_check($p);
+ $self->response->code( $p ? 204 : 201 );
+ $p ||= $self->server->data->add( $self->uri . "" );
+ $p->set( "D:getcontenttype" => $self->header("Content-Type") );
+ $p->data( $self->content );
+
+ $self->response->header( "ETag" => $p->etag );
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Report.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Method/Report.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,35 @@
+package Net::CalDAV::Server::Method::Report;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'Net::CalDAV::Server::Method';
+
+sub run {
+ my $self = shift;
+
+ # XXX: Depth header
+
+ my $xml = $self->parse_xml;
+ if ( $xml->root->tag eq "C:calendar-query" ) {
+ my @nodes
+ = $xml->find_nodes("/C:calendar-query/C:filter/C:comp-filter");
+
+ my $sub = $self->make_filter(@nodes);
+ for my $path ( values %{ $self->server->data->paths } ) {
+ next unless $path->ical;
+ next unless $sub->( $path->ical );
+ $self->props( $xml, $path );
+ }
+ } elsif ( $xml->root->tag eq "C:calendar-multiget" ) {
+ my @nodes = $xml->find_nodes("/C:calendar-multiget/D:href");
+ $self->props( $xml, $_ ) for map { $_->text } @nodes;
+ }
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Path.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Path.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,67 @@
+package Net::CalDAV::Server::Path;
+
+use warnings;
+use strict;
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+use Digest::MD5;
+use DateTime;
+use Data::ICal::DateTime;
+use Email::MIME::ContentType;
+
+has path => (
+ is => 'ro',
+ isa => 'Str',
+);
+has props => (
+ metaclass => 'Collection::Hash',
+ is => 'ro',
+ isa => 'HashRef',
+ default => sub { {} },
+ provides => {
+ get => 'get',
+ set => 'set',
+ exists => 'has',
+ delete => 'delete',
+ keys => 'list',
+ },
+ curries => {
+ get => {
+ last_modified => ['D:getlastmodified'],
+ content_type => ['D:getcontenttype'],
+ length => ['D:getcontentlength'],
+ etag => ['D:getetag'],
+ },
+ },
+);
+has data => ( is => 'rw', isa => 'Str' );
+has ical => (
+ is => 'rw',
+ isa => 'Maybe[Data::ICal]',
+);
+
+sub BUILD {
+ my $self = shift;
+ $self->set("D:creationdate" => DateTime->now->datetime . "Z");
+}
+
+after 'data' => sub {
+ my $self = shift;
+ return unless @_;
+ $self->set("D:getlastmodified" => DateTime->now->strftime("%a, %d %b %Y %H:%M:%S GMT"));
+ $self->set("D:getcontentlength" => length $_[0]);
+ $self->set("D:getetag" => Digest::MD5::md5_base64( $_[0] ) );
+ my $ct = parse_content_type($self->content_type);
+ if ($ct->{discrete} eq "text" and $ct->{composite} eq "calendar") {
+ my $ical = Data::ICal->new( data => $self->data );
+ $self->ical($ical->isa('Data::ICal') ? $ical : undef);
+ } else {
+ $self->ical(undef);
+ }
+};
+
+__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Added: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Request.pm
==============================================================================
--- (empty file)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Request.pm Mon Aug 18 15:03:55 2008
@@ -0,0 +1,69 @@
+package Net::CalDAV::Server::Request;
+
+use warnings;
+use strict;
+
+use XML::Twig;
+
+use constant D => "DAV:";
+use constant C => "urn:ietf:params:xml:ns:caldav";
+
+use Moose;
+use MooseX::AttributeHelpers;
+
+extends 'HTTP::Request';
+
+sub setup {
+ my $self = shift;
+ my %args = @_;
+ $self->method( $args{method} );
+ $self->uri( $args{request_uri} );
+ $self->protocol( $args{protocol} );
+}
+
+sub read_body {
+ my $self = shift;
+ my $body = '';
+
+ my $length = $self->header("Content-Length") || 0;
+ while ( $length > 0 ) {
+ last unless sysread( STDIN, my $read, 1 );
+ $body .= $read;
+ $length -= length $read;
+ }
+ $self->content($body);
+}
+
+sub headers {
+ my $self = shift;
+ my ($headers) = @_;
+ while ( my ( $header, $value ) = splice @$headers, 0, 2 ) {
+ $self->header($header, $value);
+ }
+ $self->read_body;
+}
+
+sub namespace_for_uri {
+ my $class = shift;
+ my $map = { D() => "D", C() => "C" };
+ return $map unless @_;
+ return $map->{ shift @_ };
+}
+
+sub uri_for_namespace {
+ my $class = shift;
+ my $map = { reverse %{ $class->namespace_for_uri } };
+ return $map unless @_;
+ return $map->{ shift @_ };
+}
+
+sub parse_xml {
+ my $self = shift;
+ my $twig = XML::Twig->new( map_xmlns => $self->namespace_for_uri, );
+ $twig->parse( $self->content );
+ return $twig;
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
+1;
Modified: experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm
==============================================================================
--- /experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm (original)
+++ experiments/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm Mon Aug 18 15:03:55 2008
@@ -9,10 +9,33 @@
use constant D => "DAV:";
use constant C => "urn:ietf:params:xml:ns:caldav";
-sub new {
- my $class = shift;
- return bless { prop => {}, href => {} }, $class;
-}
+use Moose;
+use MooseX::AttributeHelpers;
+
+has prop => (
+ is => 'ro',
+ default => sub { {} },
+ isa => 'HashRef[HashRef[HashRef]]',
+);
+
+has href => (
+ is => 'ro',
+ default => sub { {} },
+ isa => 'HashRef[HashRef[ArrayRef[Str]]]',
+);
+
+has 'response' => (
+ is => 'ro',
+ default => sub { HTTP::Response->new(207) },
+ isa => 'HTTP::Response',
+ handles => [qw/code header content protocol/]
+);
+
+has 'sent' => (
+ is => 'rw',
+ default => sub {0},
+ isa => 'Bool',
+);
sub add {
my $self = shift;
@@ -26,12 +49,6 @@
}
}
-sub status_message {
- my $self = shift;
- my ($code) = @_;
- return "HTTP/1.1 $code " . HTTP::Status::status_message($code);
-}
-
sub prop_out {
my $self = shift;
my ( $w, $prop, $value ) = @_;
@@ -39,7 +56,7 @@
$value = $prop if not defined $value and ref $prop;
my ( $ns, $local ) = split /:/, $prop, 2;
- $ns = Net::CalDAV::Server->uri_for_namespace($ns) || $ns;
+ $ns = Net::CalDAV::Server::Request->uri_for_namespace($ns) || $ns;
if ( not defined $value or not ref $value ) {
if ( defined $value ) {
@@ -60,53 +77,97 @@
}
}
-sub as_string {
+sub status_message {
my $self = shift;
+ my $code = shift || $self->code;
+ return $self->protocol . " $code " . HTTP::Status::status_message($code);
+}
- my $out = '';
- my $w = XML::Writer->new(
- OUTPUT => \$out,
- NAMESPACES => 1,
- PREFIX_MAP => Net::CalDAV::Server->namespace_for_uri,
- DATA_MODE => 1,
- DATA_INDENT => 2,
- );
- $w->xmlDecl( "utf-8" );
- $w->startTag( [ D, "multistatus" ] );
-
- for my $status ( sort keys %{ $self->{href} } ) {
- $w->startTag( [ D, "response" ] );
- $w->dataElement( [ D, "href" ], $_ ) for @{ $self->{href}{$status} };
- $w->dataElement( [ D, "status" ], $self->status_message($status) );
- $w->endTag;
- }
+sub as_string {
+ my $self = shift;
- for my $href ( sort keys %{ $self->{prop} } ) {
- $w->startTag( [ D, "response" ] );
- $w->dataElement( [ D, "href" ], $href );
- for my $status ( keys %{ $self->{prop}{$href} } ) {
- $w->startTag( [ D, "propstat" ] );
- $w->startTag( [ D, "prop" ] );
- $self->prop_out( $w, $_ => $self->{prop}{$href}{$status}{$_} )
- for keys %{ $self->{prop}{$href}{$status} };
- $w->endTag;
+ if ( $self->code == 207 and not $self->content ) {
+ my $out = '';
+ my $w = XML::Writer->new(
+ OUTPUT => \$out,
+ NAMESPACES => 1,
+ PREFIX_MAP => Net::CalDAV::Server::Request->namespace_for_uri,
+ DATA_MODE => 1,
+ DATA_INDENT => 2,
+ );
+ $w->xmlDecl("utf-8");
+ $w->startTag( [ D, "multistatus" ] );
+
+ for my $status ( sort keys %{ $self->{href} } ) {
+ $w->startTag( [ D, "response" ] );
+ $w->dataElement( [ D, "href" ], $_ )
+ for @{ $self->{href}{$status} };
$w->dataElement( [ D, "status" ],
$self->status_message($status) );
$w->endTag;
}
+ for my $href ( sort keys %{ $self->{prop} } ) {
+ $w->startTag( [ D, "response" ] );
+ $w->dataElement( [ D, "href" ], $href );
+ for my $status ( keys %{ $self->{prop}{$href} } ) {
+ $w->startTag( [ D, "propstat" ] );
+ $w->startTag( [ D, "prop" ] );
+ $self->prop_out( $w, $_ => $self->{prop}{$href}{$status}{$_} )
+ for keys %{ $self->{prop}{$href}{$status} };
+ $w->endTag;
+ local $self->{_rc} = $status;
+ $w->dataElement( [ D, "status" ],
+ $self->status_message($status) );
+ $w->endTag;
+ }
+
+ $w->endTag;
+ }
+
$w->endTag;
+ $w->end;
+
+ $self->header( "Content-Type" => 'text/xml; charset="utf-8"' );
+ $self->content($out);
}
- $w->endTag;
- $w->end;
+ $self->header( "Content-Length" => length( $self->content ) );
+
+ return $self->response->as_string("\r\n");
+}
- my $response = HTTP::Response->new(207);
- $response->header( "Content-Type" => 'text/xml; charset="utf-8"' );
- $response->header( "Content-Length" => length($out) );
- $response->content($out);
+sub send_no_auth {
+ my $self = shift;
+ $self->code(401);
+ $self->header( "WWW-Authenticate" => qq{Basic realm="CalDAV server"} );
+ $self->content("Authentication required.\n");
+ $self->send;
+}
- return "HTTP/1.1 ".$response->as_string;
+sub send_precondition_failed {
+ my $self = shift;
+ # TODO: Precondition failure XML responses?
+ $self->code(412);
+ $self->send;
}
+sub send_not_found {
+ my $self = shift;
+ $self->code(404);
+ $self->send;
+}
+
+sub send {
+ my $self = shift;
+ return if $self->sent;
+ my $content = $self->as_string;
+ print $content;
+ warn $content;
+ $self->sent(1);
+ return;
+}
+
+#__PACKAGE__->meta->make_immutable; no Moose;
+
1;
More information about the Bps-public-commit
mailing list