From 5c7f41dd473c60d02a1c09a706cfc2fa33cd4228 Mon Sep 17 00:00:00 2001
From: Milan <mc@radiopiloten.de>
Date: Sun, 6 Sep 2020 19:56:01 +0200
Subject: [PATCH] ListenerAccess.pm: file access handler with timeout

grant/deny access to files. File access is denied one week after the given
date in filename. Filenames are indirected by symbolic links.
---
 lib/calcms/ListenerAccess.pm | 50 ++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)
 create mode 100644 lib/calcms/ListenerAccess.pm

diff --git a/lib/calcms/ListenerAccess.pm b/lib/calcms/ListenerAccess.pm
new file mode 100644
index 0000000..1b06767
--- /dev/null
+++ b/lib/calcms/ListenerAccess.pm
@@ -0,0 +1,50 @@
+package ListenerAccess;
+
+use strict;
+use warnings;
+
+use Data::Dumper;
+use File::Basename;
+use Time::Local();
+
+use Apache2::RequestRec ();
+use Apache2::Connection ();
+use Apache2::Const -compile => qw(FORBIDDEN OK);
+
+sub handler {
+    my $r = shift;
+
+    my $path = $ENV{LISTENER_DIR} . File::Basename::basename( $r->uri() );
+    my $file = readlink $path;
+    unless ($file) {
+        print STDERR "cannot read link for $path\n";
+        return Apache2::Const::FORBIDDEN;
+    }
+
+    $file = File::Basename::basename($file);
+    unless ( $file =~ /(\d\d\d\d)\-(\d\d)\-(\d\d) (\d\d)_(\d\d)/ ) {
+        printf STDERR "access: cannot find datetime pattern in file:'%s'\n", $file;
+        return Apache2::Const::FORBIDDEN;
+    }
+    
+    my $start_since = time() - Time::Local::timelocal( 0, $5, $4, $3, $2 - 1, $1 );
+    $start_since /= 24 * 60 * 60;
+    if ( $start_since > 7 ) {
+        printf STDERR "access: file is not availabe anymore:'%s'\n", $file;
+        return Apache2::Const::FORBIDDEN;
+    }
+    return Apache2::Const::OK;
+}
+1;
+
+__END__
+
+# limit access up to 7 days after datetime given by filename.
+# The filename links to a file starting with "yyyy-mm-dd hh_mm" in file name.
+# 
+# <Directory ${archive_dir}/${domain}>
+#        PerlSetEnv PERL5LIB ${perl_lib}/calcms
+#        PerlSetEnv LISTENER_DIR ${archive_dir}/${domain}/
+#        PerlAccessHandler ListenerAccess
+# </Directory>
+#
\ No newline at end of file