File Coverage

lib/At/Protocol/Handle.pm

Criterion	Covered	Total	%
statement	72	81	88.8
branch	24	26	92.3
condition	8	8	100.0
subroutine	13	14	92.8
pod	7	7	100.0
total	124	136	91.1

package At::Protocol::Handle 1.0 {
    use v5.42;
    use At::Error qw[register throw];
    use parent -norequire => 'Exporter';
    use feature 'try';
    no warnings qw[experimental::try];
    use overload
        '""' => sub ( $s, $u, $q ) {
        $$s;
        };
    our %EXPORT_TAGS = (
        all => [
            our @EXPORT_OK
                = qw[
                ensureValidHandle ensureValidHandleRegex
                normalizeHandle normalizeAndEnsureValidHandle
                isValidHandle isValidTld]
        ]
    );
    #
    my $INVALID_HANDLE = 'handle.invalid';

    #~ Currently these are registration-time restrictions, not protocol-level
    #~ restrictions. We have a couple accounts in the wild that we need to clean up
    #~ before hard-disallow.
    #~ See also: https://en.wikipedia.org/wiki/Top-level_domain#Reserved_domains
    my @DISALLOWED_TLDS = (
        '.local', '.arpa', '.invalid', '.localhost', '.internal', '.example', '.alt',

        # policy could concievably change on ".onion" some day
        '.onion',

        #~ NOTE: .test is allowed in testing and devopment. In practical terms
        #~ "should" "never" actually resolve and get registered in production
    );

    sub new( $class, $id ) {
        throw UnsupportedDomainError('invalid TLD') unless isValidTld($id);
        ensureValidHandle($id);
        ensureValidHandleRegex($id);
        CORE::state $warned //= 0;
        if ( $id =~ /\.(test)$/ && !$warned ) {
            require Carp;
            Carp::carp 'development or testing TLD used in handle: ' . $id;
            $warned = 1;
        }
        bless \$id, $class;
    }

    # Taken from https://github.com/bluesky-social/atproto/blob/main/packages/syntax/src/handle.ts
    # Handle constraints, in English:
    #  - must be a possible domain name
    #    - RFC-1035 is commonly referenced, but has been updated. eg, RFC-3696,
    #      section 2. and RFC-3986, section 3. can now have leading numbers (eg,
    #      4chan.org)
    #    - "labels" (sub-names) are made of ASCII letters, digits, hyphens
    #    - can not start or end with a hyphen
    #    - TLD (last component) should not start with a digit
    #    - can't end with a hyphen (can end with digit)
    #    - each segment must be between 1 and 63 characters (not including any periods)
    #    - overall length can't be more than 253 characters
    #    - separated by (ASCII) periods; does not start or end with period
    #    - case insensitive
    #    - domains (handles) are equal if they are the same lower-case
    #    - punycode allowed for internationalization
    #  - no whitespace, null bytes, joining chars, etc
    #  - does not validate whether domain or TLD exists, or is a reserved or
    #    special TLD (eg, .onion or .local)
    #  - does not validate punycode
    sub ensureValidHandle ($handle) {

        # check that all chars are boring ASCII
        throw InvalidHandleError('Disallowed characters in handle (ASCII letters, digits, dashes, periods only)') if $handle !~ /^[a-zA-Z0-9.-]*$/;
        #
        throw InvalidHandleError('Handle is too long (253 chars max)') if length $handle > 253;
        #
        my @labels = split /\./, $handle, -1;    # negative limit, ftw
        throw InvalidHandleError('Handle domain needs at least two parts') if scalar @labels < 2;
        for my $i ( 0 .. $#labels ) {
            my $l = $labels[$i];
            throw InvalidHandleError('Handle parts can not be empty')                             if !length $l;
            throw InvalidHandleError('Handle part too long (max 63 chars)')                       if length $l > 63;
            throw InvalidHandleError('Handle parts can not start or end with hyphens')            if $l                   =~ /^-|-$/;
            throw InvalidHandleError('Handle final component (TLD) must start with ASCII letter') if $i == $#labels && $l !~ /^[a-zA-Z]/;
        }
        1;
    }

    sub ensureValidHandleRegex ($handle) {
        throw InvalidHandleError(q[Handle didn't validate via regex])
            unless $handle =~ /^([a-zA-Z0-9]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?\.)+[a-zA-Z]([a-zA-Z0-9-]{0,61}[a-zA-Z0-9])?$/;
        throw InvalidHandleError('Handle is too long (253 chars max)') if length $handle > 253;
        1;
    }

    sub normalizeHandle ($handle) {
        lc $handle;
    }

    sub normalizeAndEnsureValidHandle($handle) {
        my $normalized = normalizeHandle($handle);
        ensureValidHandle($normalized);
        $normalized;
    }

    sub isValidHandle ($handle) {
        try {
            ensureValidHandle($handle)
        }
        catch ($err) {    # TODO: I want this to work by checking the type of thrown error but this is perl...
            if ( $err =~ /Handle/ ) {
                return 0;
            }
            die $err;
        }
        1;
    }

    sub isValidTld($handle) {
        for my $tld (@DISALLOWED_TLDS) {
            return 0 if $handle =~ /${tld}$/;
        }
        1;
    }

    # All fatal errors
    register 'InvalidHandleError',     (), 1;
    register 'ReservedHandleError',    (), 1;
    register 'UnsupportedDomainError', (), 1;
    register 'DisallowedDomainError',  (), 1;
};
1;
__END__