[Bps-public-commit] r13863 - in experimental/Net-CalDAV-Server: lib lib/Net lib/Net/CalDAV lib/Net/CalDAV/Server
alexmv at bestpractical.com
alexmv at bestpractical.com
Tue Jul 8 12:16:04 EDT 2008
Author: alexmv
Date: Tue Jul 8 12:16:00 2008
New Revision: 13863
Added:
experimental/Net-CalDAV-Server/lib/
experimental/Net-CalDAV-Server/lib/Net/
experimental/Net-CalDAV-Server/lib/Net/CalDAV/
experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server/
experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm
experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm
experimental/Net-CalDAV-Server/propfind.req
Log:
* Import
Added: experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm
==============================================================================
--- (empty file)
+++ experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server.pm Tue Jul 8 12:16:00 2008
@@ -0,0 +1,190 @@
+package Net::CalDAV::Server;
+
+use warnings;
+use strict;
+
+use YAML;
+use XML::Twig;
+use Net::CalDAV::Server::Response;
+use Digest::MD5;
+use DateTime;
+
+use constant D => "DAV:";
+use constant C => "urn:ietf:params:xml:ns:caldav";
+
+use base qw/HTTP::Server::Simple Class::Accessor/;
+
+__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;
+ }
+}
+
+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 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 } );
+ }
+ }
+
+ print $self->response->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;
+ 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 $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;
+}
+
+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";
+
+}
+
+1;
Added: experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm
==============================================================================
--- (empty file)
+++ experimental/Net-CalDAV-Server/lib/Net/CalDAV/Server/Response.pm Tue Jul 8 12:16:00 2008
@@ -0,0 +1,112 @@
+package Net::CalDAV::Server::Response;
+
+use strict;
+use warnings;
+use XML::Writer;
+use HTTP::Response;
+use HTTP::Status qw//;
+
+use constant D => "DAV:";
+use constant C => "urn:ietf:params:xml:ns:caldav";
+
+sub new {
+ my $class = shift;
+ return bless { prop => {}, href => {} }, $class;
+}
+
+sub add {
+ my $self = shift;
+ my ( $href, $status, $prop, $value ) = @_;
+
+ if ( defined $prop ) {
+ $self->{prop}{$href}{$status}{$prop} = $value;
+ } else {
+ $self->{href}{$status} ||= [];
+ push @{ $self->{href}{$status} }, $href;
+ }
+}
+
+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 ) = @_;
+
+ $value = $prop if not defined $value and ref $prop;
+
+ my ( $ns, $local ) = split /:/, $prop, 2;
+ $ns = Net::CalDAV::Server->uri_for_namespace($ns) || $ns;
+
+ if ( not defined $value or not ref $value ) {
+ if ( defined $value ) {
+ $w->dataElement( [ $ns, $local ], $value );
+ } else {
+ $w->emptyTag( [ $ns, $local ] );
+ }
+ } elsif ( ref $value eq "ARRAY" ) {
+ $w->startTag( [ $ns, $local ] );
+ $self->prop_out( $w, $_ ) for @{$value};
+ $w->endTag;
+ } elsif ( ref $value eq "HASH" ) {
+ $w->startTag( [ $ns, $local ] );
+ $self->prop_out( $w, $_ => $value->{$_} ) for sort keys %{$value};
+ $w->endTag;
+ } else {
+ warn "Got a ref: $prop => $value";
+ }
+}
+
+sub as_string {
+ my $self = shift;
+
+ 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;
+ }
+
+ 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;
+ $w->dataElement( [ D, "status" ],
+ $self->status_message($status) );
+ $w->endTag;
+ }
+
+ $w->endTag;
+ }
+
+ $w->endTag;
+ $w->end;
+
+ my $response = HTTP::Response->new(207);
+ $response->header( "Content-Type" => 'text/xml; charset="utf-8"' );
+ $response->header( "Content-Length" => length($out) );
+ $response->content($out);
+
+ return "HTTP/1.1 ".$response->as_string;
+}
+
+1;
Added: experimental/Net-CalDAV-Server/propfind.req
==============================================================================
--- (empty file)
+++ experimental/Net-CalDAV-Server/propfind.req Tue Jul 8 12:16:00 2008
@@ -0,0 +1,18 @@
+PROPFIND / HTTP/1.1
+Host: localhost:8080
+User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.13pre) Gecko/20080626 Sunbird/0.8
+Accept: text/xml
+Accept-Language: en-us,en;q=0.5
+Accept-Encoding: gzip,deflate
+Accept-Charset: utf-8,*;q=0.1
+Keep-Alive: 300
+Connection: keep-alive
+Content-Length: 86
+Content-Type: text/xml; charset=utf-8
+Depth: 0
+
+<D:propfind xmlns:D="DAV:">
+ <D:prop>
+ <D:resourcetype/>
+ </D:prop>
+</D:propfind>
\ No newline at end of file
More information about the Bps-public-commit
mailing list