Permalink
Browse files

initial commit

  • Loading branch information...
0 parents commit 1265ad4a1d5df55ead3108cf8705665b1e0942cc @bricas committed Apr 22, 2009
@@ -0,0 +1,4 @@
+This file documents the revision history for Perl extension CPANHQ.
+
+0.01 2009-XX-XX
+ - initial revision, generated by Catalyst
@@ -0,0 +1,27 @@
+use inc::Module::Install;
+
+name 'CPANHQ';
+all_from 'lib/CPANHQ.pm';
+
+requires 'Catalyst::Runtime' => '5.7014';
+requires 'Catalyst::Action::RenderView';
+requires 'Catalyst::Model::DBIC::Schema';
+requires 'Catalyst::Plugin::Authentication';
+requires 'Catalyst::Plugin::Authorization::ACL';
+requires 'Catalyst::Plugin::ConfigLoader';
+requires 'Catalyst::Plugin::Session';
+requires 'Catalyst::Plugin::Static::Simple';
+requires 'Catalyst::Plugin::Session::State::Cookie';
+requires 'Catalyst::Plugin::Session::Store::File';
+requires 'Catalyst::View::TT';
+requires 'parent';
+requires 'Config::General';
+requires 'Net::OpenID::Consumer';
+requires 'LWPx::ParanoidAgent'
+requires 'Rose::HTML::Form';
+
+catalyst;
+
+install_script glob('script/*.pl');
+auto_install;
+WriteAll;
1 README
@@ -0,0 +1 @@
+Run script/cpanhq_server.pl to test the application.
@@ -0,0 +1,5 @@
+name CPANHQ
+<Model::DB>
+ connect_info dbi:SQLite:dbname=__HOME__/cpanhq.db
+ connect_info undef
+</Model::DB>
@@ -0,0 +1,86 @@
+package CPANHQ;
+
+use strict;
+use warnings;
+
+use Catalyst::Runtime '5.70';
+
+use parent qw(Catalyst);
+use Catalyst qw(
+ ConfigLoader
+ Authentication
+ Authorization::ACL
+ Session
+ Session::State::Cookie
+ Session::Store::File
+ Static::Simple
+);
+
+our $VERSION = '0.01';
+
+__PACKAGE__->config(
+ name => 'CPANHQ',
+ default_view => 'HTML',
+ setup_components => { search_extra => [ '::Form' ] },
+ authentication => {
+ default_realm => 'openid',
+ realms => {
+ openid => {
+ auto_create_user => 1,
+ credential => {
+ class => 'Password',
+ password_type => 'none',
+ },
+ store => {
+ class => 'DBIx::Class',
+ user_class => 'DB::Account',
+ id_field => 'id',
+ role_relation => 'roles',
+ role_field => 'name',
+ }
+ }
+ }
+ }
+);
+
+__PACKAGE__->setup();
+
+__PACKAGE__->deny_access_unless( '/authenticate/login', sub { ! shift->user_exists } );
+__PACKAGE__->deny_access_unless( '/authenticate/logout', sub { shift->user_exists } );
+
+sub form {
+ my ( $c, $name, @args ) = @_;
+
+ # this will break in 5.71
+ return $c->_filter_component( $c->_comp_prefixes( $name, 'Form' ),
+ @args );
+}
+
+=head1 NAME
+
+CPANHQ - Perl from the trenches
+
+=head1 SYNOPSIS
+
+ script/cpanhq_server.pl
+
+=head1 DESCRIPTION
+
+[enter your description here]
+
+=head1 SEE ALSO
+
+L<CPANHQ::Controller::Root>, L<Catalyst>
+
+=head1 AUTHOR
+
+Brian Cassidy E<lt>bricas@cpan.orgE<gt>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
@@ -0,0 +1,56 @@
+package CPANHQ::Base::Form;
+
+use strict;
+use warnings;
+
+use parent 'Rose::HTML::Form';
+
+sub COMPONENT {
+ return shift->new;
+}
+
+sub ACCEPT_CONTEXT {
+ my ( $self, $c, @args ) = @_;
+
+ $self->reset;
+ $self->app( $c );
+ $self->params( $c->req->params );
+ $self->init_fields();
+
+ return $self;
+}
+
+sub is_valid {
+ return shift->validate( @_ );
+}
+
+sub was_submitted {
+ my $self = shift;
+ return lc $self->app->req->method eq $self->method;
+}
+
+sub render {
+ my $self = shift;
+ my $output = '';
+
+ if ( $self->error ) {
+ $output .= $self->xhtml_error;
+ }
+
+ $output .= $self->start_xhtml;
+
+ for my $field ( map { $self->field( $_ ) } $self->field_names_by_rank ) {
+ $output .= $field->xhtml_label . $field->xhtml;
+ }
+
+ $output .= $self->end_xhtml;
+ return $output;
+}
+
+sub field_names_by_rank {
+ my $self = shift;
+ return map { $_->name }
+ sort { $a->rank <=> $b->rank } $self->fields;
+}
+
+1;
@@ -0,0 +1,70 @@
+package CPANHQ::Controller::Authenticate;
+
+use strict;
+use warnings;
+
+use parent qw( Catalyst::Controller );
+
+use Net::OpenID::Consumer;
+use LWPx::ParanoidAgent;
+
+sub login : Path('/login') Args(0) {
+ my ( $self, $c ) = @_;
+ my $form = $c->form( 'Login' );
+ $c->stash( form => $form );
+
+ return unless $form->was_submitted && $form->is_valid;
+
+ my $consumer = Net::OpenID::Consumer->new(
+ ua => LWPx::ParanoidAgent->new,
+ args => $c->req->params,
+ consumer_secret => sub { $_[0] },
+ );
+
+ my $identity = $consumer->claimed_identity( $form->field_value( 'claimed_uri' ) );
+ my $url = $identity->check_url(
+ return_to => $c->uri_for('/authenticate/openid'),
+ trust_root => $c->uri_for('/'),
+ delayed_return => 1,
+ );
+
+ $c->res->redirect( $url );
+}
+
+sub openid : Path('openid') Args(0) {
+ my( $self, $c ) = @_;
+
+ if( !$c->req->params->{ 'openid.identity' } ) {
+ $c->res->redirect( $c->uri_for( '/login' ) );
+ return;
+ }
+
+ my $consumer = Net::OpenID::Consumer->new(
+ ua => LWPx::ParanoidAgent->new,
+ args => $c->req->params,
+ consumer_secret => sub { $_[0] },
+ );
+
+ if ( my $setup = $consumer->user_setup_url ) {
+ $c->res->redirect( $setup );
+ }
+ elsif ($consumer->user_cancel) {
+ $c->res->redirect( $c->uri_for( '/login' ) );
+ }
+ elsif ( my $identity = $consumer->verified_identity ) {
+ $c->authenticate( { enabled => 1, openid => $identity->url }, 'openid' );
+ $c->res->redirect( $c->uri_for( '/' ) );
+ }
+ else {
+ Catalyst::Exception->throw('Error validating identity: ' . $consumer->errtext);
+ }
+}
+
+sub logout : Path('/logout') Args(0) {
+ my ( $self, $c ) = @_;
+
+ $c->logout;
+ $c->res->redirect( $c->uri_for( '/' ) );
+}
+
+1;
@@ -0,0 +1,76 @@
+package CPANHQ::Controller::Root;
+
+use strict;
+use warnings;
+
+use parent 'Catalyst::Controller';
+
+__PACKAGE__->config->{namespace} = '';
+
+=head1 NAME
+
+CPANHQ::Controller::Root - Root Controller for CPANHQ
+
+=head1 DESCRIPTION
+
+[enter your description here]
+
+=head1 METHODS
+
+=cut
+
+=head2 index
+
+=cut
+
+sub index :Path :Args(0) {
+ my ( $self, $c ) = @_;
+
+ # Hello World
+ $c->response->body( $c->welcome_message );
+}
+
+sub default :Path {
+ my ( $self, $c ) = @_;
+ $c->response->body( 'Page not found' );
+ $c->response->status(404);
+
+}
+
+=head2 end
+
+Attempt to render a view, if needed.
+
+=cut
+
+sub end : ActionClass('RenderView') {}
+
+sub access_denied : Private {
+ my( $self, $c, $action ) = @_;
+
+ if( !$c->user_exists ) {
+ $c->redirect( '/login' );
+ return;
+ }
+
+ # non-fatal
+ if ( $action eq $c->controller('Authenticate')->action_for('login') ) {
+ $c->res->redirect( '/' );
+ return;
+ }
+
+ die 'access denied'; # TODO
+}
+
+=head1 AUTHOR
+
+Brian Cassidy E<lt>bricas@cpan.orgE<gt>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
@@ -0,0 +1,17 @@
+package CPANHQ::Form::Login;
+
+use strict;
+use warnings;
+
+use parent qw( CPANHQ::Base::Form );
+
+sub build_form {
+ my $self = shift;
+
+ $self->add_fields( claimed_uri => { type => 'text', size => 40, required => 1 }, submit => { type => 'submit', value => 'Login' } );
+ $self->method( 'post' );
+
+ return $self;
+}
+
+1;
@@ -0,0 +1,12 @@
+package CPANHQ::Model::DB;
+
+use strict;
+use warnings;
+
+use base qw( Catalyst::Model::DBIC::Schema );
+
+__PACKAGE__->config(
+ schema_class => 'CPANHQ::Storage'
+);
+
+1;
@@ -0,0 +1,13 @@
+package CPANHQ::ResultSet::Account;
+
+use strict;
+use warnings;
+
+use base qw( DBIx::Class::ResultSet );
+
+sub auto_create {
+ my ( $self, $authinfo ) = @_;
+ $self->create( { openid => $authinfo->{ openid }, } );
+}
+
+1;
@@ -0,0 +1,10 @@
+package CPANHQ::Storage;
+
+use strict;
+use warnings;
+
+use base qw( DBIx::Class::Schema );
+
+__PACKAGE__->load_classes;
+
+1;
Oops, something went wrong.

0 comments on commit 1265ad4

Please sign in to comment.