initial commit

Changes

@@ -0,0 +1,4 @@
+This file documents the revision history for Perl extension CPANHQ.
+
+0.01  2009-XX-XX
+        - initial revision, generated by Catalyst

Makefile.PL

@@ -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;

README

@@ -0,0 +1 @@
+Run script/cpanhq_server.pl to test the application.

cpanhq.conf

@@ -0,0 +1,5 @@
+name CPANHQ
+<Model::DB>
+    connect_info    dbi:SQLite:dbname=__HOME__/cpanhq.db
+    connect_info    undef
+</Model::DB>

lib/CPANHQ.pm

@@ -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;

lib/CPANHQ/Base/Form.pm

@@ -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;

lib/CPANHQ/Controller/Authenticate.pm

@@ -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;

lib/CPANHQ/Controller/Root.pm

@@ -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;

lib/CPANHQ/Form/Login.pm

@@ -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;

lib/CPANHQ/Model/DB.pm

@@ -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;

lib/CPANHQ/ResultSet/Account.pm

@@ -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;

lib/CPANHQ/Storage.pm

@@ -0,0 +1,10 @@
+package CPANHQ::Storage;
+
+use strict;
+use warnings;
+
+use base qw( DBIx::Class::Schema );
+
+__PACKAGE__->load_classes;
+
+1;