102 lines
2.9 KiB
Perl
102 lines
2.9 KiB
Perl
#!/usr/bin/perl
|
|
#
|
|
# DW::External::Site::Atproto
|
|
#
|
|
# Support class for elements shared between atproto-based sites. Links to
|
|
# aturi.to to provide a whole-account overview for atproto..
|
|
#
|
|
# Authors:
|
|
# Joshua Barrett <jjbarr@ptnote.dev>
|
|
#
|
|
# Copyright (c) 2026 by Dreamwidth Studios LLC.
|
|
#
|
|
# This program is free software; you can redistribute it and/or
|
|
# modify it under the same terms as Perl itself. For a copy of the
|
|
# license, please reference 'perldoc perlartistic' or 'perldoc perlgpl'.
|
|
#
|
|
|
|
package DW::External::Site::Atproto;
|
|
|
|
use strict;
|
|
use base 'DW::External::Site';
|
|
use Carp qw/ croak /;
|
|
|
|
# new does nothing for these classes
|
|
sub new { croak 'cannot build with new'; }
|
|
|
|
# returns an object if we allow this domain; else undef
|
|
sub accepts {
|
|
my ( $class, $parts ) = @_;
|
|
|
|
# let's just assume the last two parts are good if we have them
|
|
return undef unless scalar(@$parts) >= 2;
|
|
|
|
return bless { hostname => "$parts->[-2].$parts->[-1]" }, $class;
|
|
}
|
|
|
|
# argument: DW::External::User
|
|
# returns URL to this account's journal
|
|
sub journal_url {
|
|
my ( $self, $u ) = @_;
|
|
croak 'need a DW::External::User'
|
|
unless $u && ref $u eq 'DW::External::User';
|
|
|
|
# we don't currently expose a way to reference "an atproto account" which
|
|
# may or may not have a bluesky profile or other services attached. But
|
|
# sending the user to aturi is the correct way to handle that since it
|
|
# presents the well-known sites the account DOES have a profile on in and
|
|
# end-user friendly way.
|
|
return 'https://aturi.to/' . $u->user;
|
|
}
|
|
|
|
# argument: DW::External::User
|
|
# returns URL to this account's journal
|
|
sub profile_url {
|
|
my ( $self, $u ) = @_;
|
|
croak 'need a DW::External::User'
|
|
unless $u && ref $u eq 'DW::External::User';
|
|
|
|
return $self->journal_url($u);
|
|
}
|
|
|
|
# argument: DW::External::User
|
|
# returns info for the badge image (head icon) for this user
|
|
sub badge_image {
|
|
my ( $self, $u ) = @_;
|
|
croak 'need a DW::External::User'
|
|
unless $u && ref $u eq 'DW::External::User';
|
|
|
|
# for lack of anything better, let's use the favicon
|
|
return {
|
|
url => "https://atproto.com/en/icon.ico",
|
|
width => 16,
|
|
height => 16,
|
|
};
|
|
}
|
|
|
|
# Bluesky/atproto has somewhat unique username rules because usernames must be
|
|
# FQDNs. It is also expected that usernames be canonicalized to lowercase, as
|
|
# per https://atproto.com/specs/handle. This doesn't fully validate usernames,
|
|
# but it will reject anything blatantly wrong (in particular, it does not check
|
|
# the length of the segments... I think everything else is in here?).
|
|
#
|
|
# TODO: Should this also accept raw DIDs?
|
|
sub canonical_username {
|
|
my $input = $_[1];
|
|
my $user = "";
|
|
|
|
if (
|
|
$input =~ m/
|
|
^\s*
|
|
((?:(?:[a-z0-9][a-z0-9\-]*)?[a-z0-9]\.)+
|
|
[a-z](?:[a-z0-9\-]*[a-z0-9])?)
|
|
\s*$
|
|
/ix
|
|
)
|
|
{
|
|
$user = lc $1;
|
|
}
|
|
return $user;
|
|
}
|
|
|
|
1;
|