Git::Fingerd - let people finger your git server for... some reason

Git-Fingerd documentation Contained in the Git-Fingerd distribution.

Index

Code Index:

NAME

Top

Git::Fingerd - let people finger your git server for... some reason

VERSION

Top

version 2.093520

DESCRIPTION

Top

This module implements a simple finger server that describes the contents of a server that hosts git repositories. You can finger @servername for a listing of repositories and finger repo@servername for information about a single repository.

This was meant to provide a simple example for Net::Finger::Server, but enough people asked for the code that I've released it as something reusable. Here's an example program using Git::Fingerd:

  #!/usr/bin/perl
  use Git::Fingerd -run => {
    isa     => 'Net::Server::INET',
    basedir => '/var/lib/git',
  };

This program could then run out of xinetd.

AUTHOR

Top

  Ricardo SIGNES <rjbs@cpan.org>

COPYRIGHT AND LICENSE

Top

This software is copyright (c) 2009 by Ricardo SIGNES.

This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.

Git-Fingerd documentation Contained in the Git-Fingerd distribution. 
use strict;
use warnings;
package Git::Fingerd;
our $VERSION = '2.093520';
use Net::Finger::Server 0.003;
BEGIN { our @ISA = qw(Net::Finger::Server); }
# ABSTRACT: let people finger your git server for... some reason

use Git::PurePerl;
use List::Util qw(max);
use Path::Class;
use SUPER;
use String::Truncate qw(elide);
use Text::Table;


sub new {
  my ($class, %config) = @_;

  my $basedir = delete $config{basedir} || Carp::croak('no basedir supplied');
  my $self = $class->SUPER(%config, log_level => 0);
  $self->{__PACKAGE__}{basedir} = $basedir;

  return $self;
}

sub basedir { $_[0]->{__PACKAGE__}{basedir} }

sub username_regex { qr{[-a-z0-9]+}i   }

sub listing_reply {
  my $basedir = $_[0]->basedir;
  my @dirs = sort <$basedir/*>;

  my $table = Text::Table->new('Repository', '  Description');

  my %repo;

  for my $i (reverse 0 .. $#dirs) {
    my $dir = $dirs[$i];
    my $mode = (stat $dir)[2];
    unless ($mode & 1) {
      splice @dirs, $i, 1;
      next;
    }

    my $repo = $dir;
    s{\A$basedir/}{}, s{\.git\z}{} for $repo;
    my $desc = `cat $dir/description`;
    chomp $desc;

    $repo{ $repo } = $desc;
  }

  my $desc_len = 79 - 3 - (List::Util::max map { length } keys %repo);

  for my $repo (sort { lc $a cmp lc $b } keys %repo) {
    $table->add($repo => '  ' . elide($repo{$repo}, $desc_len));
  }

  return "$table";
}

sub user_reply {
  my ($self, $username, $arg) = @_;

  my $basedir = $self->basedir;
  my $gitdir  = "$basedir/$username.git";

  return "unknown repository\n" unless -d $gitdir;

  my $mode = (stat $gitdir)[2];

  return "unknown repository\n" unless $mode & 1;

  my $repo    = Git::PurePerl->new({ gitdir => $gitdir });

  my $cloneurl = file( $gitdir, 'cloneurl' )->slurp( chomp => 1 );
  my $desc     = $repo->description;
  chomp($cloneurl, $desc);

  my @refs = $repo->ref_names;
  my @tags  = grep { s{^refs/tags/}{} } @refs;
  my @heads = grep { s{^refs/heads/}{} } @refs;

  my $reply = "Project  : $username
Desc.    : $desc
Clone URL: $cloneurl
";

  $reply .= "\n[heads]\n";
  for my $head (sort @heads) {
    my $sha = $repo->ref_sha1("refs/heads/$head");
    $reply .= sprintf "%-15s = %s\n", $head, $sha;
  }

  $reply .= "\n[tags]\n";
  for my $tag (sort @tags) {
    my $sha = $repo->ref_sha1("refs/tags/$tag");
    $reply .= sprintf "%-15s = %s\n", $tag, $sha;
  }

  if (my $ref = $repo->ref("refs/heads/master")) {
    my $tree = $ref->tree;
    for ($tree->directory_entries) {
      next unless $_->filename eq 'README';
      my $obj = $_->object;
      $reply .= "\n[README]\n" . $obj->content . "\n";
    }
  }

  return $reply;
}

1;

__END__