#  Quick and dirty facsimile of Apache mod_index
#
<start_html 
    title="File Index" 
    include_style="@{qw(index.css)}"
    style="@{qw(
        https://cdn.jsdelivr.net/gh/highlightjs/cdn-release@11.9.0/build/styles/atom-one-dark.min.css
        https://cdn.jsdelivr.net/npm/@picocss/pico@2/css/pico.classless.min.css
    )}" 
    meta="%{viewport=>'width=device-width, initial-scale=1.0'}"
    script="@{qw(
        https://cdn.jsdelivr.net/npm/htmx.org@1.9.5
        https://cdn.jsdelivr.net/npm/alpinejs@3/dist/cdn.min.js#defer
        https://cdn.jsdelivr.net/gh/highlightjs/cdn-release@11.11.1/build/highlight.min.js
        https://cdn.jsdelivr.net/npm/lucide@latest/dist/umd/lucide.js#defer
    )}"
    include_script="@{qw(index.js)}"
    handler="WebDyne"
>




<perl handler="index" run="!{! !shift()->r->header('hx-request') !}">
<header>
  <h1>Index of <span id="current-path">${path_dn}</span></h1>
  <hr>
</header>

<main>
  <table role="grid">
    <thead>
      <tr>
        <th><a href="${sort_name_href}">Filename</a></th>
        <th><a href="${sort_mtime_href}">Last Modified</a></th>
        <th><a href="${sort_size_href}">Size</a></th>
        <th style="text-align: right">View</th>
      </tr>
    </thead>
    <tbody>
      <block name="index">
      <tr>
        <td><a href="${href}">${filename}</a></td>
        <td>${date}</td>
        <td>${size}</td>
        
            <block name="file" display="!{! $_[1]->{'type'} eq 'file' !}" >
            <td style="text-align: right"  x-data="{ isOpen: false }">
                <a href="#" @click.prevent="toggleSourceRow($el, $data)" class="cursor-pointer inline-flex items-center gap-1"  data-filename="${filename}" data-md5="${md5_hex}">
                    <svg data-lucide="chevron-left" width="16" height="16" :style="isOpen ? 'transform: rotate(-90deg)' : ''" style="transition: transform .15s ease-in-out;"></svg>
                </a>
            </td>
            </block>

            <block name="dir" display="!{! $_[1]->{'type'} eq 'dir' !}">
            <td style="text-align: right">
            -
            </td>
            </block>

      </tr>
      </block>
    </tbody>
  </table>
</main>


<footer>
  <hr>
  <small>Generated on ${timestamp} by WebDyne Indexer in ${sec} sec.</small>
</footer>
</perl>


<!-- HTMX section start -->

<htmx display="+{source}" handler="source">
<tr class="source-row" id="source-row-${md5_hex}" data-md5="${md5_hex}"><td colspan="4">

<block name="source">
<script  data-lang="${lang}" type="text/plain">${code}</script>
</block>

<pre><code class="hljs" id="srce_highlight-${md5_hex}"></code></pre>

</td></tr>
</htmx>

<!-- HTMX section end -->


__PERL__

use strict;
use File::stat;
use File::Spec::Unix;
use File::Basename qw(dirname fileparse);
use POSIX qw(strftime);
use WebDyne::Constant;
use WebDyne::Util;
use Cwd qw(realpath);
use IO::File;
use Digest::MD5 qw(md5_hex);


sub source {


    #  Get source file and display
    #
    my $self=shift();
    my $cgi_or=$self->CGI() ||
        return err('unable to get CGI object');
    
    
    #  Massage to get full file name path and sanity check file is 
    #  under document_root
    #
    my $srce_fn=$_{'source'} ||
        return err('no filename to display');
    my $full_dn=$self->full_dn() ||
        return err('no full_dn');
    my $path_fn=File::Spec->catfile($full_dn, $srce_fn);
    $path_fn=$self->test_fn($path_fn) || do {
        debug("null return from test_fn for path: $path_fn");
        my $lang='text';
        my $text='[Blocked]';
        $self->render_block('source', lang=>$lang, code=>$text);
        return $self->render(
            language    => $lang, 
            md5_hex     => md5_hex($srce_fn)
        );
    };
        

    #  Vars we need
    #
    my $srce;
    my @srce_html;
    my @srce_lang;
    my $perl;
    
    
    #  Open and run through file line by line, splitting out perl and HTML bits
    #
    my $path_fh=IO::File->new($path_fn, O_RDONLY) ||
        return err("unable to open file: $srce_fn, $!");
    
    
    #  If not .psp file then flick perl flag so goes into the lang bucket
    #
    unless ($srce_fn=~/\.psp$/) { $perl++ }
    
    
    #  Now iterate over file
    #
    my ($binary, $lang);  
    while (my $line=<$path_fh>) {
        
        if ($line =~ /[\x00-\x08\x0B\x0C\x0E-\x1F\x80-\xFF]/) {
            push @srce_lang, '[Binary file - not displaying]';
            $lang='text';
            $binary++;
            last;
        }

        if ($line=~/^__PERL__/) {
            $perl++;
        }
        if ($perl) {
            push @srce_lang, $line
        }
        else {
            push @srce_html, $line
        }
    }
    
    
    #  Get mapping hash
    #
    my $ext_to_lang_hr=&ext_to_lang();
    my ($ext)=($srce_fn=~/\.(.*?)$/);
    $lang ||= $ext_to_lang_hr->{$ext};
    $lang ||= $ext ? 'automatic' : 'text';
    
    
    #  Concatenate together and escape </script> tag in HTML, then render
    #
    #
    if (my $srce_html=join(undef, @srce_html)) {
        $srce_html=~s/<\/script>/<\\\/script>/gm;
        $self->render_block('source', lang=>'html', code=>$srce_html);
    }
    if (my $srce_lang=join(undef, @srce_lang)) {
        $srce_lang=~s/<\/script>/<\\\/script>/gm;
        $self->render_block('source', lang=>$lang, code=>$srce_lang);
    }
        

    #  And render
    #
    return $self->render(
        language    => $lang, 
        md5_hex     => md5_hex($srce_fn)
    );
    
}


sub test_fn {

    
    #  Check if file type OK and path not outside root_dn
    #
    my ($self, $test_fn)=@_;
    my $cgi_or=$self->CGI() ||
         return err('unable to get CGI object');
    my $r=$self->r() || 
        return err('unable to get request object');
        
        
    #  Return if not a real file
    #
    $test_fn=$self->sanitize_path($cgi_or, $test_fn) || do {
        debug("fail, sanitize_path null return for fn: $test_fn");
        return undef;
    };
    
    
    #  Get just the filename
    #
    my $fn_only=(File::Spec->splitpath($test_fn))[2] || do {
        debug("file, unable to get filename component for fn: $test_fn");
        return undef;
    };
    
    
    #  Return if extension not OK
    #
    my $ext=lc((fileparse($test_fn, qr/\.[^.]*/))[2]);
    $ext=~s/^\.//;
    unless ($WEBDYNE_MIME_TYPE_HR->{$ext} || $WEBDYNE_INDEX_EXT_ALLOWED_HR->{$ext} || $WEBDYNE_INDEX_FN_ALLOWED_HR->{$fn_only}) {
        debug("fail, file extenstion: $ext not supported MIME type for fn: $test_fn");
        return undef;
    }
    
    
    #  Return if no realpath
    #
    unless (realpath($test_fn)) {
        debug("fail, no realpath() for fn: $test_fn");
        return undef;
    }
    
    
    #  No dot files, .. etc.
    #
    if ($test_fn=~/\/\.+/) {
        debug("fail, not showing files with leading . for fn: $test_fn");
        return undef;
    }
    if ( $test_fn=~/^\.+/) {
        debug("fail, not showing files with multiple .. for fn: $test_fn");
        return undef;
    }
    
    
    #  Get directory
    #
    my $test_dn=dirname(realpath($test_fn)) || do {
        debug("fail, dirname not returned for fn: $test_fn");
        return undef;
    };


    #  Now check not higher than document root
    #    
    my $root_dn=$r->document_root() || do {
        debug('fail, root_dn not found !');
        return undef;
    };
    if (!defined($test_dn) || (index($test_dn,$root_dn) !=0)) {
        # Bad person, trying to escape
        debug("fail, escape detected for dn: $test_dn, root_dn: $root_dn");
        return undef;
    }
    elsif (-l  $test_fn) {
        debug("fail, file is symlink for fn: $test_fn");
        return undef;
    }
    elsif (! -f $test_fn) {
        debug("fail, file not found for fn: $test_fn");
        return undef;
    }
    elsif (! -r _) {
        debug("fail, file not readable for fn: $test_fn");
        return undef;
    }
    elsif (! -s _) {
        debug('fail, file is zero size');
        return undef;
    }
    elsif (! -f _) {
        debug('fail, file is not regular file');
        return undef;
    }
    else {
        debug("returning fn: $test_fn");
        return $test_fn if -f _;
    }
    

    #  Fail safe
    #
    debug('fail, test cases not matched');
    return undef;
    
}


sub full_dn {


    #  Get the full dn of the URI location we are currently at
    #
    my ($self, $path_dn)=@_;
    my $cgi_or=$self->CGI() ||
         return err('unable to get CGI object');
    my $r=$self->r() || 
        return err('unable to get request object');


    #  Where do we want to be ? Use File::Spec::Unix rather than URI, 
    #  it's not happy when we don't have a base component.
    #
    $path_dn ||= $self->sanitize_path($cgi_or, ($r->path_info() || $ENV{'PATH_INFO'})) ||
        return err('unable to get path');
    debug("path_dn: $path_dn");
        
    
    #  Now get real dn and check not higher than document root
    #    
    my $root_dn=$r->document_root();
    my $full_dn;
    for (1..2) { # Max 2 loops to check and sanitise path
        $full_dn=File::Spec->catdir($root_dn, split(m{/+}, $path_dn));
        $full_dn=realpath($full_dn);
        if (!defined($full_dn) || (index($full_dn,$root_dn) !=0)) {
            # Bad person, trying to escape
            $full_dn=$root_dn;
            next;
        }
        elsif(-f $full_dn) {
            #  Clicked on a file URL which isn't recognised. Go back to index
            #
            $path_dn=dirname($path_dn);
            next;
        }
        last;
    }
    
    
    #  Reset if things go bad
    #
    unless ($full_dn && (-d $full_dn)) {
        $full_dn=$root_dn;
    }
    
    
    #  Done;
    #
    return $full_dn;
    
}
    

sub index {


    #  Index current directory
    #
    my $self=shift();
    
    
    #  Get request object
    #
    my $r=$self->r() || 
        return err('unable to get request object');
    my $cgi_or=$self->CGI() ||
         return err('unable to get CGI object');


    #  Where do we want to be ? Use File::Spec::Unix rather than URI, 
    #  it's not happy when we don't have a base component.
    #
    my $path_dn=$self->sanitize_path($cgi_or, ($r->path_info() || $ENV{'PATH_INFO'})) ||
        return err('unable to get path');
        
    
    #  Now get real dn and check not higher than document root
    #    
    my $root_dn=$r->document_root();
    my $full_dn=$self->full_dn() ||
        return err('no full_dn');

    
    #  Reset if things go bad
    #
    unless ($full_dn && (-d $full_dn)) {
        $full_dn=$root_dn;
        $path_dn='/';
    }
    
    
    #  And iterate over it to get file names and stat info
    #
    opendir(my $dh, $full_dn) ||
        return err("unable to open directory $full_dn, $!");
    my @fn;
    my %fn;
    while (my $fn=readdir($dh)) {
        # Skip any special files, [.],[..] etc.
        next if ($fn=~/^\./);
        $fn.='/' if (-d File::Spec->catfile($full_dn, $fn));
        my $fn_or=stat(File::Spec->catfile($full_dn,$fn)) || next;
        #debug("fn: $fn");
        push @fn, $fn;
        map { $fn{$fn}{$_}=$fn_or->$_ } qw(size mtime);
        $fn{$fn}{'name'}=$fn;
    }
    
    
    #  Create Parent Directory link unless we're at top level
    #
    unless ($path_dn eq '/') {
        my $parent_dn=dirname($path_dn);
        $self->render_block('index',
            filename   => 'Parent Directory',
            href        => $parent_dn,
            date       => '',
            size       => ''
            
        );
    }
    

    #  Sort by user selected sort field, or by name if no sort selected
    #
    my $fn_ar;
    my $sort_fg;
    foreach my $sort_type (qw(name size mtime)) {
        if ($_{"sort_${sort_type}"}) {
            $fn_ar=$self->sort_file(\@fn, \%fn, $sort_type, $_{"sort_${sort_type}_order"});
            $sort_fg++;
            last; 
        }
    }
    unless ($sort_fg) {
        #  Default sort is by name
        $fn_ar=$self->sort_file(\@fn, \%fn, 'name', $_{'sort_name_order'});
    }
        
    
    #  Now go over every file in sort order and format info, build output
    # 
    foreach my $fn (@{$fn_ar}) {
    
        
        #  Mtime and Size in human readable format
        #
        #my $mtime=strftime('%X', localtime($fn{$fn}{'mtime'}));
        my $mtime=strftime('%Y-%m-%d %H:%M:%S', localtime($fn{$fn}{'mtime'}));
        my $size=$self->human_size($fn{$fn}{'size'});
        
        
        #  Build file href differently if dir vs file
        #
        my ($href, $type);
        if ($fn=~m{/$}) {
            #  Dir
            $href=File::Spec->catdir($path_dn, split(m{/+}, $fn));
            $type='dir';
        }
        else {
            #  Normal file
            $href=File::Spec->catfile($path_dn, $fn);
            $type='file';
        }
        

        #  Attrs we will need
        #
        my %data=(
            filename    => $fn,
            href        => $href || $fn,
            date        => $mtime,
            size        => $size,
            md5_hex     => md5_hex($fn),
            type        => $type
        );
        
        
        #  Now render info about file into page
        #
        $self->render_block('index', %data);
        
    }
    
    
    #  Construct the sort hrefs
    #
    use URI;
    my %query=$cgi_or->Vars();
    #  Delete any existing sort params when creating href lower/
    map {delete @query{("sort_${_}", "sort_${_}_order")} } qw(name size mtime);
    my %sort_href;
    foreach my $sort_type (qw(name size mtime)) {
        my $uri_or=URI->new();
        $uri_or->query_form(%{{%query, "sort_${sort_type}"=>1, "sort_${sort_type}_order"=>$_{"sort_${sort_type}_order"}?0:1 }});
        $sort_href{"sort_${sort_type}_href"}=$uri_or;
    }
    

    #  And fill out page
    #
    my %param=(
        path_dn         => $path_dn,
        timestamp       => strftime('%X', localtime()),
        sec             => sprintf('%.3f', $self->render_time()),
        %sort_href
    );
    
    
    #  Done
    #
    return $self->render(%param);
    
}


sub sort_file {

    #  Sort by name, size, mtime but keep directories at top
    #
    my ($self, $fn_ar, $fn_hr, $field, $desc)=@_;
    my @fn=sort {

        # Keep folders at top
        #
        my $dn_a = ($fn_hr->{$a}{'name'} =~ m{/$}) ? 1 : 0;
        my $dn_b = ($fn_hr->{$b}{'name'} =~ m{/$}) ? 1 : 0;
        if ($dn_a && !$dn_b) { return -1 }
        if ($dn_b && !$dn_a) { return 1 }
        
        my $cmp;
        if ($field eq 'name') {
            $cmp=lc($fn_hr->{$a}{$field}) cmp lc($fn_hr->{$b}{$field})
        }
        else {
            $cmp=$fn_hr->{$a}{$field} <=> $fn_hr->{$b}{$field};
            if ($cmp == 0) {
                #  Secondary sort by name if size or mtime equal
                $cmp=lc($fn_hr->{$a}{'name'}) cmp lc($fn_hr->{$b}{'name'})
            }
        }
        $desc ? -$cmp : $cmp
    } @{$fn_ar};
    return \@fn;
    
}


sub human_size {

    #  Return human readable bytes size suffixes
    #
    my ($self, $size)=@_;
    #return '0' unless $size && $size > 0;

    my @units = (undef, qw(K M G T P));
    my $i = 0;

    while (($size >= 1024) && ($i < (@units - 1))) {
        $size /= 1024;
        $i++;
    }
    return $units[$i] ? sprintf("%.1f%s", $size, $units[$i]) : $size;
}


sub sanitize_path {

    my ($self, $cgi_or, $dn)=@_;
    $dn=$cgi_or->url_decode($dn);
    $dn =~ s/[\x00-\x1F\x7F]//g;
    $dn =~ s{//+}{/}g;
    $dn =~ s{^/*}{/};
    $dn =~ s{/$}{} unless $dn eq '/';
    $dn = File::Spec->canonpath($dn);
    $dn =~ s{[^A-Za-z0-9_\-.\s/]}{}g;
    $dn ='/' unless $dn =~ m{^/};
    return $dn;
    
}


sub ext_to_lang {

    my %ext_to_lang = (
    
        # Perl
        'pl'      => 'perl',
        'pm'      => 'perl',
        't'       => 'perl',
        'psp'     => 'perl',
        'PL'      => 'perl',

        # Python
        'py'      => 'python',

        # Ruby
        'rb'      => 'ruby',

        # JavaScript & TypeScript
        'js'      => 'javascript',
        'jsx'     => 'javascript',
        'ts'      => 'typescript',
        'tsx'     => 'typescript',

        # Web
        'html'    => 'xml',  # HTML is treated as XML in highlight.js
        'htm'     => 'xml',
        'xml'     => 'xml',
        'css'     => 'css',
        'scss'    => 'scss',

        # JSON / YAML / Config
        'json'    => 'json',
        'yaml'    => 'yaml',
        'yml'     => 'yaml',
        'ini'     => 'ini',
        'toml'    => 'toml',

        # Bash / Shell
        'sh'      => 'bash',
        'bash'    => 'bash',
        'zsh'     => 'bash',

        # C / C++
        'c'       => 'c',
        'h'       => 'cpp',  # highlight.js prefers 'cpp'
        'cpp'     => 'cpp',
        'cc'      => 'cpp',
        'cxx'     => 'cpp',
        'hpp'     => 'cpp',
        'hxx'     => 'cpp',

        # Java / JVM
        'java'    => 'java',
        'kt'      => 'kotlin',
        'kts'     => 'kotlin',
        'scala'   => 'scala',
        'groovy'  => 'groovy',

        # C#
        'cs'      => 'csharp',

        # PHP
        'php'     => 'php',

        # Go
        'go'      => 'go',

        # Rust
        'rs'      => 'rust',

        # Swift / Apple
        'swift'   => 'swift',
        'm'       => 'objectivec',
        'mm'      => 'objectivec',

        # SQL
        'sql'     => 'sql',

        # R
        'r'       => 'r',

        # Lua
        'lua'     => 'lua',

        # Markdown / Text
        'md'      => 'markdown',
        'markdown'=> 'markdown',
        'txt'     => 'plaintext',

        # Makefiles & build
        'makefile'=> 'makefile',
        'mk'      => 'makefile',
        'cmake'   => 'cmake',

        # Docker / CI
        'dockerfile' => 'dockerfile',
        'env'        => 'bash',

        # LaTeX
        'tex'     => 'latex',

        # Assembly
        'asm'     => 'x86asm',
        's'       => 'x86asm',

        # Powershell
        'ps1'     => 'powershell'
        
    );
    
    return \%ext_to_lang
    
}

     