File Coverage

blib/lib/Klonk/Routes.pm

Criterion	Covered	Total	%
statement	12	133	9.0
branch	0	78	0.0
condition	0	19	0.0
subroutine	4	11	36.3
pod	3	4	75.0
total	19	245	7.7

package Klonk::Routes 0.01;
use Klonk::pragma;
use Carp qw(croak);
use HTML::Blitz ();
use Klonk::Env ();

our %routes;

fun _parse_route($pattern) {
    my @segments;
    while () {
        $pattern =~ m{\G ( / [^`*]*+ (?: `[`*] [^`*]*+ )*+ ) }xgc
            or croak "Malformed route pattern (must start with '/'): '$pattern'";
        my $raw = $1;
        $raw =~ s/`([`*])/$1/g;
        push @segments, $raw;
        if ($pattern =~ m{\G \z}x) {
            last;
        }
        if ($pattern =~ m{\G `}x) {
            croak "Malformed route pattern ('`' must be followed by '`' or '*'): '$pattern'";
        }
        if ($pattern =~ m{\G (?<= / ) \*\* \z}xgc) {
            push @segments, undef;
            last;
        }
        if ($pattern =~ m{\G (?<= / ) \* }xgc) {
            if ($pattern =~ m{\G \z}x) {
                push @segments, '';
                last;
            }
            $pattern =~ m{\G / }x
                or croak "Malformed route pattern ('*' must be followed by '/'): '$pattern'";
        } else {
            croak "Malformed route pattern ('*' must be preceded by '/') :'$pattern'";
        }
    }
    \@segments
}

my $dispatch_info;

fun mkroute($pattern, %handlers) {
    my (undef, $filename, $line) = caller;
    my $location = [$filename, $line];

    $dispatch_info = undef;
    my $def = $routes{$pattern} //= do {
        my $chunks = _parse_route $pattern;
        my $weight = join('', map chr(defined $_ ? 1 + length : 0), @$chunks) . "\x{7fff_ffff}";
        #say STDERR sprintf "weight(%s): %vd", $pattern, $weight;
        +{
            chunks   => $chunks,
            weight   => $weight,
            resource => {},
        }
    };

    for my $pmethod (sort keys %handlers) {
        my $method = uc $pmethod;
        my $resource = $def->{resource};
        exists $resource->{$method}
            and croak "Redefinition of $method $pattern (previously defined at $resource->{$method}{location}[0] line $resource->{$method}{location}[1])";
        $resource->{$method} = {
            location => $location,
            handler  => $handlers{$pmethod},
        };
    }
}

my $redirect_template = do {
    my $blitz = HTML::Blitz->new(
        { dummy_marker_re => qr/\bXXX\b/ },
        [ 'a[href=URL]' =>
            [ 'set_attribute_var', href => 'url' ],
            [ 'replace_inner_var', 'url' ],
        ],
        [ 'title, h1' =>
            [ 'replace_inner_text', "308 Permanent Redirect" ]
        ],
    );

    my $template = $blitz->apply_to_html(
        '(inline_redirect)',
        'XXXXXXSee XXX'
    );

    $template->compile_to_sub
};

fun _routes_prepare() {
    my $gen = 'a';
    my %mapping;
    my $regex = join '|',
        map {
            my @chunks = @{$_->[2]};
            my $rest = defined $chunks[-1] ? 0 : (pop @chunks, 1);
            my $re = join '([^/]*+)', map quotemeta, @chunks;
            $re .= '(.*+)' if $rest;
            $re .= "(*:$gen)";
            $mapping{$gen++} = $_->[0];
            $re
        }
        sort { $b->[1] cmp $a->[1] || $a->[0] cmp $b->[0] }
        map [$_, @{$routes{$_}}{'weight', 'chunks'}],
        keys %routes;
    $regex = '(?!)' if $regex eq '';
    #say STDERR ">>> $regex";
    #use re 'debugcolor';
    [
        qr/\A(?|$regex)\z/s,
        \%mapping,
    ]
}

my %text_types = (
    'css'    => 'text/css',
    'csv'    => 'text/csv',
    'html'   => 'text/html',
    'js'     => 'text/javascript',
    'json'   => 'application/json',
    'jsonld' => 'application/ld+json',
    'text'   => 'text/plain',
);

my %bin_types = (
    'bin'  => 'application/octet-stream',
    'jpeg' => 'image/jpeg',
    'png'  => 'image/png',
    'webp' => 'image/webp',
);

fun _postprocess($ret) {
    my $status = 200;
    if ($ret->[0] =~ /\A\d{3}\z/a) {
        $status = shift @$ret;
    }
    my ($itype, $body, $headers) = @$ret;

    for my $spec (
        [\%text_types, 1],
        [\%bin_types, 0],
    ) {
        my ($type_map, $encode_p) = @$spec;
        if (my $type = $type_map->{$itype}) {
            if ($encode_p) {
                utf8::encode $body unless ref $body;
                $type .= '; charset=utf-8';
            }
            my $length = ref $body
                ? -s $body || undef
                : length $body;
            return [
                $status,
                [
                    'content-type' => $type,
                    defined $length
                        ? ('content-length' => $length)
                        : (),
                    map {
                        my $k = $_;
                        my $v = $headers->{$k};
                        map +($k => $_), ref($v) eq 'ARRAY' ? @$v : $v
                    }
                    keys %{$headers // {}}
                ],
                ref $body ? $body : [ $body ]
            ];
        }
    }

    die "Unknown content type: $itype";
}

my $booted;
my @init;

fun on_init($fun) {
    croak "Can't call on_init() after boot()" if $booted;
    push @init, $fun;
}

fun dispatch($env) {
    my $kenv = Klonk::Env->new($env);
    my $req_path   = $env->{PATH_INFO};
    my $req_method = $env->{REQUEST_METHOD};

    $dispatch_info //= _routes_prepare;
    local our $REGMARK;
    if (my @captures = $req_path =~ /$dispatch_info->[0]/) {
        my $pattern = $dispatch_info->[1]{$REGMARK};
        my $meta = $routes{$pattern};
        splice @captures, $#{$meta->{chunks}};
        my $resource = $meta->{resource};
        if (my $info = $resource->{$req_method}) {
            my $handler = $info->{handler};
            return _postprocess $handler->($kenv, @captures);
        }

        if ($req_method eq 'HEAD' && (my $info = $resource->{GET})) {
            my $ret = _postprocess $info->{handler}($kenv, @captures);
            return [ 204, $ret->[1], [] ];
        }

        my $allowed_methods = join ', ', sort keys %$resource;
        if ($req_method eq 'OPTIONS') {
            return [ 204, [ 'allow' => $allowed_methods ], [] ];
        }

        return _postprocess [
            405,
            'html',
            "405 Method Not Allowed405 Method Not Allowed",
            { allow => $allowed_methods }
        ];
    }

    if ($req_path !~ m{/\z} && "$req_path/" =~ /$dispatch_info->[0]/) {
        my $uri = $env->{REQUEST_URI};
        $uri =~ s{(?=[?#])|\z}{/};
        return _postprocess [
            308,
            'html',
            $redirect_template->({ url => $uri }),
            {
                'location' => $uri,
            },
        ];
    }

    return _postprocess [
        404,
        'html',
        "404 Not Found404 Not Found",
    ];
}

fun boot() {
    $booted = 1;
    my @fun = splice @init;
    for my $fun (@fun) {
        $fun->();
    }

    \&dispatch
}

1
__END__