1 files changed, 161 insertions, 0 deletions
diff --git a/src/lib/Gitolite/Cache.pm b/src/lib/Gitolite/Cache.pm
new file mode 100644
index 0000000..351a13e
--- /dev/null
+++ b/src/lib/Gitolite/Cache.pm
@@ -0,0 +1,161 @@
+package Gitolite::Cache;
+
+# cache stuff using an external database (redis)
+# ----------------------------------------------------------------------
+
+@EXPORT = qw(
+  cache_control
+  cache_wrap
+);
+
+use Exporter 'import';
+
+use Gitolite::Common;
+use Gitolite::Rc;
+use Storable qw(freeze thaw);
+use Redis;
+
+my $redis;
+
+my $redis_sock = "$ENV{HOME}/.redis-gitolite.sock";
+if ( -S $redis_sock ) {
+    _connect_redis();
+} else {
+    _start_redis();
+    _connect_redis();
+
+    # this redis db is a transient, caching only, db, so let's not
+    # accidentally use any stale data when if we're just starting up
+    cache_control('stop');
+    cache_control('start');
+}
+
+# ----------------------------------------------------------------------
+
+my %wrapped;
+my $ttl = ( $rc{CACHE_TTL} || ( $rc{GROUPLIST_PGM} ? 900 : 90000 ) );
+
+sub cache_control {
+    my $op = shift;
+    if ( $op eq 'stop' ) {
+        $redis->flushall();
+    } elsif ( $op eq 'start' ) {
+        $redis->set( 'cache-up', 1 );
+    } elsif ( $op eq 'flush' ) {
+        flush_repo(@_);
+    }
+}
+
+sub cache_wrap {
+    my $sub   = shift;
+    my $tname = $sub;    # this is what will show up in the trace output
+    trace( 3, "wrapping '$sub'" );
+    $sub = ( caller 1 )[0] . "::" . $sub if $sub !~ /::/;
+    return if $wrapped{$sub}++;    # in case somehow it gets called twice for the same sub!
+
+    # collect names of wrapped subs into a redis 'set'
+    $redis->sadd( "SUBWAY", $sub );    # subway?  yeah well they wrap subs don't they?
+
+    my $cref = eval '\&' . $sub;
+    my %opt  = @_;
+        # rest of the options come in as a hash.  'list' says this functions
+        # returns a list.  'ttl' is a number to override the default ttl for
+        # the cached value.
+
+    no strict 'refs';
+    no warnings 'redefine';
+    *{$sub} = sub {                    # the wrapper function
+        my $key = join( ", ", @_ );
+        trace( 2, "$tname.args", @_ );
+
+        if ( cache_up() and defined( my $val = $redis->get("$sub: $key") ) ) {
+            # cache is up and we got a hit, return value from cache
+            if ( $opt{list} ) {
+                trace( 2, "$tname.getl", @{ thaw($val) } );
+                return @{ thaw($val) };
+            } else {
+                trace( 2, "$tname.get", $val );
+                return $val;
+            }
+        } else {
+            # cache is down or we got a miss, compute
+            my ( $r, @r );
+            if ( $opt{list} ) {
+                @r = $cref->(@_);    # provide list context
+                trace( 2, "$tname.setl", @r );
+            } else {
+                $r = $cref->(@_);    # provide scalar context
+                trace( 2, "$tname.set", $r );
+            }
+
+            # store computed value in cache if cache is up
+            if ( cache_up() ) {
+                $redis->set( "$sub: $key", ( $opt{list} ? freeze( \@r ) : $r ) );
+                $redis->expire( "$sub: $key", $opt{ttl} || $ttl );
+                trace( 2, "$tname.ttl", ( $opt{ttl} || $ttl ) );
+            }
+
+            return @r if $opt{list};
+            return $r;
+        }
+    };
+    trace( 3, "wrapped '$sub'" );
+}
+
+sub cache_up {
+    return $redis->exists('cache-up');
+}
+
+sub flush_repo {
+    my $repo = shift;
+
+    my @wrapped = $redis->smembers("SUBWAY");
+    for my $func (@wrapped) {
+        # if we wrap any more functions, make sure they're functions where the
+        # first argument is 'repo'
+        my @keys = $redis->keys("$func: $repo, *");
+        $redis->del( @keys ) if @keys;
+    }
+}
+
+# ----------------------------------------------------------------------
+
+sub _start_redis {
+    my $conf = join( "", <DATA> );
+    $conf =~ s/%HOME/$ENV{HOME}/g;
+
+    open( REDIS, "|-", "/usr/sbin/redis-server", "-" ) or die "start redis server failed: $!";
+    print REDIS $conf;
+    close REDIS;
+
+    # give it a little time to come up
+    select( undef, undef, undef, 0.2 );
+}
+
+sub _connect_redis {
+    $redis = Redis->new( sock => $redis_sock, encoding => undef ) or die "redis new failed: $!";
+    $redis->ping or die "redis ping failed: $!";
+}
+
+1;
+
+__DATA__
+# resources
+maxmemory 50MB
+port 0
+unixsocket %HOME/.redis-gitolite.sock
+unixsocketperm 700
+timeout 0
+databases 1
+
+# daemon
+daemonize yes
+pidfile %HOME/.redis-gitolite.pid
+dbfilename %HOME/.redis-gitolite.rdb
+dir %HOME
+
+# feedback
+loglevel notice
+logfile %HOME/.redis-gitolite.log
+
+# we don't save