[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 Exporter 'import';

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.
Use of these methods additionally adds an automatic HTTP code 405
C<Method Not Allowed> response 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 support at the end of the chain for the OPTIONS method.
This defaults to HTTP 200 OK + Allows http headers.

We also 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);
659a3608	6	use Exporter 'import';
456dc2bb	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
b54172e8	115	L<Web::Simple> based application.
	116	Use of these methods additionally adds an automatic HTTP code 405
	117	C<Method Not Allowed> response if none of the HTTP methods match for a given dispatch and
456dc2bb	118	also adds a dispatch rule for C<HEAD> if no C<HEAD> exists but a C<GET> does
	119	(in which case the C<HEAD> returns the C<GET> dispatch with an empty body.)
	120
b54172e8	121	We also add support at the end of the chain for the OPTIONS method.
b54172e8	122	This defaults to HTTP 200 OK + Allows http headers.
456dc2bb	123
b54172e8	124	We also try to set correct HTTP headers such as C<Allows> as makes sense based
456dc2bb	125	on your dispatch chain.
	126
	127	The following dispatch chains are basically the same:
	128
	129	sub dispatch_request {
	130	sub (/get-http-methods) {
	131	GET { [200, ['Content-Type' => 'text/plain'], ['Hello World']] }
	132	},
	133	sub(/get-classic) {
	134	sub (GET) { [200, ['Content-Type' => 'text/plain'], ['Hello World']] },
	135	sub (HEAD) { [200, ['Content-Type' => 'text/plain'], []] },
	136	sub (OPTIONS) {
	137	[200, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'], []];
	138	},
	139	sub () {
	140	[405, ['Content-Type' => 'text/plain', Allows=>'GET,HEAD,OPTIONS'],
	141	['Method Not Allowed']]
	142	},
	143	}
	144	}
	145
	146	The idea here is less boilerplate to distract the reader from the main point of
	147	the code and also to encapsulate some best practices.
	148
	149	B<NOTE> You currently cannot mix http method style and prototype sub style in
	150	the same scope, as in the following example:
	151
	152	sub dispatch_request {
	153	sub (/get-head) {
	154	GET { ... }
	155	sub (HEAD) { ... }
	156	},
	157	}
	158
	159	If you try this our code will notice and issue a C<die>. If you have a good use
	160	case please bring it to the authors.
	161
	162	=head2 EXPORTS
	163
	164	This automatically exports the following subroutines:
	165
	166	GET
	167	PUT
	168	POST
	169	HEAD
	170	DELETE
	171	OPTIONS
	172
	173	=head1 AUTHOR
	174
	175	See L<Web::Simple> for AUTHOR
	176
	177	=head1 CONTRIBUTORS
	178
	179	See L<Web::Simple> for CONTRIBUTORS
	180
	181	=head1 COPYRIGHT
	182
	183	See L<Web::Simple> for COPYRIGHT
	184
	185	=head1 LICENSE
	186
	187	See L<Web::Simple> for LICENSE
	188
189	=cut
190