[catagits/Web-Simple.git] / lib / Web / Dispatch / HTTPMethods.pm

package Web::Dispatch::HTTPMethods;

use strictures 1;
use Web::Dispatch::Predicates qw(match_method);
use Scalar::Util qw(blessed);
use base qw(Exporter);

our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS);

sub HEAD(&;@) { method_helper(HEAD => @_) }
sub GET(&;@) { method_helper(GET => @_) }
sub POST(&;@) { method_helper(POST => @_) }
sub PUT(&;@) { method_helper(PUT => @_) }
sub DELETE(&;@) { method_helper(DELETE => @_) }
sub OPTIONS(&;@) { method_helper(OPTIONS => @_) }

{
  package Web::Dispatch::HTTPMethods::Endpoint;

  sub new { bless { map { $_=>0 } @EXPORT }, shift }
  sub hdrs { 'Content-Type' => 'text/plain' }

  sub create_implicit_HEAD {
    my $self = shift;
    if($self->{GET} && not $self->{HEAD}) {
      $self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] };
    }
  }

  sub create_implicit_OPTIONS {
    my $self = shift;
    $self->{OPTIONS} = sub {
      [200, [$self->hdrs, Allow=>$self->allowed] , [] ];
    };
  }

  sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT }

  sub to_app {
    my $self = shift;
    my $implicit_HEAD = $self->create_implicit_HEAD;
    my $implicit_OPTIONS = $self->create_implicit_OPTIONS;

    return sub {
      my $env = shift;
      if($env->{REQUEST_METHOD} eq 'HEAD') {
        $implicit_HEAD->($env);
      } elsif($env->{REQUEST_METHOD} eq 'OPTIONS') {
        $implicit_OPTIONS->($env);
      } else {
        [405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ];
      }
    };
  }
}

sub isa_endpoint {
  blessed($_[0]) &&
    $_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint')
}

sub endpoint_from { return $_[-1] }
sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) }

sub method_helper {
  my $predicate = match_method(my $method = shift);
  my ($code, @following ) = @_;
  endpoint_from( my @dispatchers = 
    scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint)
   )->{$method} = $code;

  die "Non HTTP Method dispatcher detected in HTTP Method scope"
   unless(isa_endpoint($dispatchers[-1]));

  return @dispatchers; 
}


1;

=head1 NAME

Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier

=head1 SYNOPSIS

    package MyApp:WithHTTPMethods;

    use Web::Simple;
    use Web::Dispatch::HTTPMethods;

    sub as_text {
      [200, ['Content-Type' => 'text/plain'],
        [$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ]
    }

    sub dispatch_request {
      sub (/get) {
        GET { as_text(pop) }
      },
      sub (/get-head) {
        GET { as_text(pop) }
        HEAD { [204,[],[]] },
      },
      sub (/get-post-put) {
        GET { as_text(pop) }  ## NOTE: no commas separating http methods
        POST { as_text(pop) }
        PUT { as_text(pop) }
      },
    }

=head1 DESCRIPTION

Exports the most commonly used HTTP methods as subroutine helpers into your
L<Web::Simple> based application.  Additionally adds an automatic HTTP code 405
C<Method Not Allow> if none of the HTTP methods match for a given dispatch and
also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
(in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)

We also add at the end of the chain support for the OPTIONS method (if you do
not add one yourself.  This defaults to http 200 ok + Allows http headers.

Also we try to set correct HTTP headers such as C<Allows> as makes sense based
on your dispatch chain.

The following dispatch chains are basically the same:

    sub dispatch_request {
      sub (/get-http-methods) {
        GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
      },
      sub(/get-classic) {
        sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
        sub (HEAD)  { [200, ['Content-Type' => 'text/plain'], []] },
        sub (OPTIONS)  {
          [200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
        },
        sub () {
          [405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], 
           ['Method Not Allowed']]
        },
      }
    }

The idea here is less boilerplate to distract the reader from the main point of
the code and also to encapsulate some best practices.

B<NOTE> You currently cannot mix http method style and prototype sub style in
the same scope, as in the following example:

    sub dispatch_request {
      sub (/get-head) {
        GET { ... }
        sub (HEAD) { ... }
      },
    }

If you try this our code will notice and issue a C<die>.  If you have a good use
case please bring it to the authors.  

=head2 EXPORTS

This automatically exports the following subroutines:

    GET
    PUT
    POST
    HEAD
    DELETE
    OPTIONS

=head1 AUTHOR

See L<Web::Simple> for AUTHOR

=head1 CONTRIBUTORS

See L<Web::Simple> for CONTRIBUTORS

=head1 COPYRIGHT

See L<Web::Simple> for COPYRIGHT

=head1 LICENSE

See L<Web::Simple> for LICENSE

=cut
Commit	Line	Data
456dc2bb	1	package Web::Dispatch::HTTPMethods;
	2
	3	use strictures 1;
	4	use Web::Dispatch::Predicates qw(match_method);
	5	use Scalar::Util qw(blessed);
	6	use base qw(Exporter);
	7
	8	our @EXPORT = qw(GET HEAD POST PUT DELETE OPTIONS);
	9
	10	sub HEAD(&;@) { method_helper(HEAD => @_) }
	11	sub GET(&;@) { method_helper(GET => @_) }
	12	sub POST(&;@) { method_helper(POST => @_) }
	13	sub PUT(&;@) { method_helper(PUT => @_) }
	14	sub DELETE(&;@) { method_helper(DELETE => @_) }
	15	sub OPTIONS(&;@) { method_helper(OPTIONS => @_) }
	16
	17	{
	18	package Web::Dispatch::HTTPMethods::Endpoint;
	19
	20	sub new { bless { map { $_=>0 } @EXPORT }, shift }
	21	sub hdrs { 'Content-Type' => 'text/plain' }
	22
	23	sub create_implicit_HEAD {
	24	my $self = shift;
	25	if($self->{GET} && not $self->{HEAD}) {
	26	$self->{HEAD} = sub { [ @{$self->{GET}->(@_)}[0,1], []] };
	27	}
	28	}
	29
	30	sub create_implicit_OPTIONS {
	31	my $self = shift;
	32	$self->{OPTIONS} = sub {
	33	[200, [$self->hdrs, Allow=>$self->allowed] , [] ];
	34	};
	35	}
	36
	37	sub allowed { join ',', grep { $_[0]->{$_} } @EXPORT }
	38
	39	sub to_app {
	40	my $self = shift;
	41	my $implicit_HEAD = $self->create_implicit_HEAD;
	42	my $implicit_OPTIONS = $self->create_implicit_OPTIONS;
	43
	44	return sub {
	45	my $env = shift;
	46	if($env->{REQUEST_METHOD} eq 'HEAD') {
	47	$implicit_HEAD->($env);
	48	} elsif($env->{REQUEST_METHOD} eq 'OPTIONS') {
	49	$implicit_OPTIONS->($env);
	50	} else {
	51	[405, [$self->hdrs, Allow=>$self->allowed] , ['Method Not Allowed'] ];
	52	}
	53	};
	54	}
	55	}
	56
	57	sub isa_endpoint {
	58	blessed($_[0]) &&
	59	$_[0]->isa('Web::Dispatch::HTTPMethods::Endpoint')
	60	}
	61
	62	sub endpoint_from { return $_[-1] }
	63	sub new_endpoint { Web::Dispatch::HTTPMethods::Endpoint->new(@_) }
	64
65	sub method_helper {
66	my $predicate = match_method(my $method = shift);
67	my ($code, @following ) = @_;
68	endpoint_from( my @dispatchers =
69	scalar(@following) ? ($predicate, @_) : ($predicate, @_, new_endpoint)
70	)->{$method} = $code;
71
72	die "Non HTTP Method dispatcher detected in HTTP Method scope"
73	unless(isa_endpoint($dispatchers[-1]));
74
75	return @dispatchers;
76	}
77
78
79	1;
80
81	=head1 NAME
82
83	Web::Dispatch::HTTPMethods - Helpers to make RESTFul Dispatchers Easier
84
85	=head1 SYNOPSIS
86
87	package MyApp:WithHTTPMethods;
88
89	use Web::Simple;
90	use Web::Dispatch::HTTPMethods;
91
92	sub as_text {
93	[200, ['Content-Type' => 'text/plain'],
94	[$_[0]->{REQUEST_METHOD}, $_[0]->{REQUEST_URI}] ]
95	}
96
97	sub dispatch_request {
98	sub (/get) {
99	GET { as_text(pop) }
100	},
101	sub (/get-head) {
102	GET { as_text(pop) }
103	HEAD { [204,[],[]] },
104	},
105	sub (/get-post-put) {
106	GET { as_text(pop) } ## NOTE: no commas separating http methods
107	POST { as_text(pop) }
108	PUT { as_text(pop) }
109	},
110	}
111
112	=head1 DESCRIPTION
113
29c7cff1	114	Exports the most commonly used HTTP methods as subroutine helpers into your
456dc2bb	115	L<Web::Simple> based application. Additionally adds an automatic HTTP code 405
	116	C<Method Not Allow> if none of the HTTP methods match for a given dispatch and
	117	also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
	118	(in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)
	119
	120	We also add at the end of the chain support for the OPTIONS method (if you do
	121	not add one yourself. This defaults to http 200 ok + Allows http headers.
	122
	123	Also we try to set correct HTTP headers such as C<Allows> as makes sense based
	124	on your dispatch chain.
	125
	126	The following dispatch chains are basically the same:
	127
	128	sub dispatch_request {
	129	sub (/get-http-methods) {
	130	GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
	131	},
	132	sub(/get-classic) {
	133	sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
	134	sub (HEAD) { [200, ['Content-Type' => 'text/plain'], []] },
	135	sub (OPTIONS) {
	136	[200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
	137	},
	138	sub () {
	139	[405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'],
	140	['Method Not Allowed']]
	141	},
	142	}
	143	}
	144
	145	The idea here is less boilerplate to distract the reader from the main point of
	146	the code and also to encapsulate some best practices.
	147
	148	B<NOTE> You currently cannot mix http method style and prototype sub style in
	149	the same scope, as in the following example:
	150
	151	sub dispatch_request {
	152	sub (/get-head) {
	153	GET { ... }
	154	sub (HEAD) { ... }
	155	},
	156	}
	157
	158	If you try this our code will notice and issue a C<die>. If you have a good use
	159	case please bring it to the authors.
	160
	161	=head2 EXPORTS
	162
	163	This automatically exports the following subroutines:
	164
	165	GET
	166	PUT
	167	POST
	168	HEAD
	169	DELETE
	170	OPTIONS
	171
	172	=head1 AUTHOR
	173
	174	See L<Web::Simple> for AUTHOR
	175
	176	=head1 CONTRIBUTORS
	177
	178	See L<Web::Simple> for CONTRIBUTORS
179
180	=head1 COPYRIGHT
181
182	See L<Web::Simple> for COPYRIGHT
183
184	=head1 LICENSE
185
186	See L<Web::Simple> for LICENSE
187
188	=cut
189