AnyEvent/MCP/Config.pm

=head1 NAME

AnyEvent::MCP::Config - named servers and derived MCP credentials

=head1 SYNOPSIS

   use AnyEvent::MCP::Config;

   my $config = AnyEvent::MCP::Config->global;
   my $token = $config->credential ("token", "agni");
   my $url = $config->http_url ("agni", undef, path => "/");

=head1 DESCRIPTION

An MCP server and its clients often need matching credentials. Rather than
maintaining a separate password for each server and user, this module can
derive them from one private master secret. The invoked program basename,
instance name, optional username and credential purpose each contribute to
the result. Instances default to C<default>; different programs still derive
different credentials for that instance name.

The shared file format is described in L<AnyEvent::MCP/GLOBAL CONFIGURATION>.
Loading this module does not read any files. The first call to C<global>
reads the configuration, ensures a master secret exists and caches the object
for the process.

A missing secret is generated using C<AnyEvent::MCP::random_bytes> and saved
when possible. Saving failure produces a warning; the generated secret remains
usable in this process, but another process might derive different credentials.
A supplied invalid secret is an error. Changing or losing the master secret
invalidates all credentials derived from it.

Derivation uses C<derive_secret> with the random master key.
The application namespace, purpose, program, instance name and username are
separately length-prefixed, so distinct contexts derive different credentials.
Deriving a password does not create an account or configure the server to
accept it: authentication still belongs to the server.

=head1 METHODS

=over

=item $config = AnyEvent::MCP::Config->global (file => $file)

Returns the cached global configuration. The first call accepts the same
arguments as C<new>; later calls return the same object without rereading
the file. Call this explicitly during program startup.

=item $config = AnyEvent::MCP::Config->new (file => $file)

Reads C<$file>, or the default file when omitted, and ensures a master
secret exists. Unlike C<global>, each call creates an independent object.
A missing file is allowed; other read errors are fatal. Sections are available
as C<< $config->{section}{$section} >>, each a hash reference of string
values. Named servers use C<[instance NAME]>.

=item $config = AnyEvent::MCP::Config->init (file => $file)

Explicitly creates the configuration file with a random secret, mode 0600.
Creates missing parent directories with mode 0700. Fails if the file already
exists, so it cannot accidentally replace an existing secret.

=item $bytes = $config->derive_secret ($length, @info)

=item $bytes = AnyEvent::MCP::Config->derive_secret ($length, @info)

Derive C<$length> secret bytes from the configuration's master secret and
an ordered list of context byte strings C<@info>. The class form uses
C<global>, loading the default configuration on first use and reusing it
thereafter. The object form uses that object's configuration, including
one loaded from an explicit file.

The same master secret and context always produce the same bytes. Use a
distinctive application/purpose string as the first context field, followed
by names or other values identifying the result:

   my $secret = AnyEvent::MCP::Config->derive_secret (
      32, "my application token v1", AnyEvent::MCP::utf8enc ($name)
   );

The result contains raw bytes; encode it yourself if a printable token is
needed. This method does not add the result to a server's accepted tokens.

The fixed C<anyevent-mcp> context field is prepended automatically.
Context fields are separately length-prefixed, so C<("ab", "c")> and
C<("a", "bc")> have different contexts. Encode character strings explicitly,
for example with C<AnyEvent::MCP::utf8enc>. Context arguments are left
unchanged.

C<$length> must be an integer in 0..16320; zero returns an empty string.
Shorter results are prefixes of longer results for the same master secret
and context. Use distinct context fields for different purposes, rather
than relying on different lengths to separate them.

Derivation uses HKDF-SHA512 expansion, with each context field prefixed by
its four-byte big-endian byte length. Changing or losing the master secret
changes every result derived from it.

=item $credential = $config->credential ($purpose, $name, $username)

Derives a 32-byte credential, returned as unpadded URL-safe Base64.
C<$purpose> is C<token>. C<$name> is the instance name, and C<$username>
is optional. The default server credential is derived with no username.

Credentials use the context C<("anyevent-mcp", "token", PROGRAM, NAME, USER)>.
PROGRAM is the invoked basename, with a trailing C<.pl> or C<.perl> removed.
Changing the program or instance name changes the credential. This derivation
replaces the older name-only context; update stored client URLs.
A credential derived with C<$username> is B<not> automatically accepted
by the server. This method neither requires a server section nor configures
authentication.

=item $program = AnyEvent::MCP::Config::program_name ()

Returns the invoked program basename, stripping C<.pl> or C<.perl>.
An inline Perl invocation uses C<perl>. This identity also selects the
C<[program PROGRAM]> configuration section; it is independent of routing aliases.

=item $name = AnyEvent::MCP::Config::server_name ($name)

Validate a service-instance name, or use C<default> if undefined.
Names consist of an ASCII letter or underscore followed by letters, digits,
underscores or hyphens.

=item @options = AnyEvent::MCP::Config::http_getopt (\$name, \$bind, \$print_url, \@tokens)

Return standard C<Getopt::Long> options referring to the caller's scalars.

=item $port = $config->server_port ($name)

Derive a stable default port in 16384..32767 from the master secret and
program basename and service-instance name. Collisions produce ordinary listener bind errors.

=item %settings = $config->http_settings ($name, $bind)

Resolve HTTP settings from C<[instance NAME]> and an optional command-line
C<bind> override. The default is IPv4 loopback and the name-derived port.
The bind setting accepts C<ADDRESS:PORT>, C<[IPv6]:PORT>, C<ADDRESS>,
and C<:PORT> (which keeps the default loopback address).
Hostnames are resolved once when settings are obtained; their original
spelling is advertised unless C<url_host> overrides it. The returned options
include C<name>, C<host>, C<port> and C<tokens>, plus configured C<path>,
C<url_host> and C<url_scheme>. This does not start a listener.

=item $url = $config->http_url ($name, $bind, %options)

Format a URL containing the first accepted token, without listening.
Port zero cannot be used because the kernel has not yet selected a port.
When the token is derived, the master secret must be persistently stored,
so the next process derives the same URL. Explicit static tokens and
C<auth =E<gt> "none"> do not require that persistence check.

=back

=cut

package AnyEvent::MCP::Config;

use common::sense;
use AnyEvent::MCP ();
use Digest::SHA ();
use MIME::Base64 ();
use File::Basename ();
use File::Path ();
use Fcntl qw(O_WRONLY O_RDWR O_CREAT O_EXCL LOCK_EX);
use Errno qw(ENOENT);
use AnyEvent::Socket ();
use Socket ();

our @ISA = qw(AnyEvent::MCP::Base);

sub _file {
   my $dir = $ENV{XDG_CONFIG_HOME}
      || ($ENV{HOME} || die "HOME is not set\n") . "/.config";

   "$dir/anyevent-mcp/global.ini"
}

my $global;

sub global {
   my $class = shift;

   $global ||= $class->new (@_)
}

sub new {
   my ($class, %kv) = @_;

   my $self = $class->SUPER::new (section => {}, %kv);
   $self->{file} = _file unless exists $self->{file};

   if (open my $fh, "<:encoding(UTF-8)", $self->{file}) {
      $self->_read ($fh);
      close $fh or die "$self->{file}: $!\n";
   } else {
      die "$self->{file}: $!\n" unless $! == ENOENT;
   }

   $self->_ensure_secret;

   $self->{section}{global}{secret} =~ /\A[0-9a-fA-F]{128}\z/
      or die "$self->{file}: invalid secret; supply 128 hexadecimal digits\n";

   $self
}

sub _read {
   my ($self, $fh) = @_;

   my @stat = stat $fh;
   die "$self->{file}: configuration must be private and owned by this user\n"
      if $stat[4] != $< || $stat[2] & 077;

   local $/;
   AnyEvent::MCP::parse_ini scalar (<$fh>), sub {
      my ($name, $kv) = @_;
      my $section = $self->{section}{$name || "global"} ||= {};
      %$section = (%$section, %$kv);
   }, $self->{file};

}

sub _ensure_secret {
   my ($self) = @_;

   return if exists $self->{section}{global}{secret};

   my $secret = eval { unpack "H*", AnyEvent::MCP::random_bytes 64 };
   die "$@Supply a securely generated 128-digit hexadecimal secret in $self->{file}\n"
      if $@;

   eval {
      File::Path::mkpath (File::Basename::dirname ($self->{file}), 0, 0700);
      sysopen my $fh, $self->{file}, O_RDWR | O_CREAT, 0600
         or die "$self->{file}: $!\n";
      flock $fh, LOCK_EX or die "$self->{file}: $!\n";
      binmode $fh, ":encoding(UTF-8)";

      my $disk = bless { file => $self->{file}, section => {} }, ref $self;
      $disk->_read ($fh);

      unless (exists $disk->{section}{global}{secret}) {
         seek $fh, 0, 2 or die "$self->{file}: $!\n";
         print {$fh} "\n[global]\nsecret = $secret\n"
            or die "$self->{file}: $!\n";
         $disk->{section}{global}{secret} = $secret;
      }

      close $fh or die "$self->{file}: $!\n";
      $self->{section} = $disk->{section};
      1
   } or warn "Cannot save MCP master secret; credentials may only be stable for this process: $@";

   $self->{section}{global}{secret} = $secret
      unless exists $self->{section}{global}{secret};
}

sub init {
   my ($class, %kv) = @_;

   my $file = exists $kv{file} ? $kv{file} : _file;

   my $secret = AnyEvent::MCP::random_bytes 64;

   File::Path::mkpath (File::Basename::dirname ($file), 0, 0700);

   sysopen my $fh, $file, O_WRONLY | O_CREAT | O_EXCL, 0600
      or die "$file: $!\n";

   print {$fh} "[global]\nsecret = ", unpack ("H*", $secret), "\n"
      or die "$file: $!\n";
   close $fh or die "$file: $!\n";

   $class->new (file => $file)
}

sub _prk_derive_secret($$@) {
   my ($prk, $length, @info) = @_;

   64 == length $prk
      or die "derive_secret: key length must be 64 octets\n";
   $length =~ /\A[0-9]+\z/ && $length <= 255 * 64
      or die "derive_secret: length must be an integer in 0..16320\n";

   my $info = pack "(N/a*)*", "anyevent-mcp", @info;
   my $t   = "";
   my $okm = "";
   my $i   = 0;

   while ($length > length $okm) {
      $t = Digest::SHA::hmac_sha512 $t . $info . chr ++$i, $prk;
      $okm .= $t;
   }

   substr $okm, 0, $length
}

sub derive_secret {
   my ($self, $length, @info) = @_;

   $self = $self->global unless ref $self;

   my $secret = $self->{section}{global}{secret};
   $secret =~ /\A[0-9a-fA-F]{128}\z/
      or die "$self->{file}: missing or invalid secret\n";

   _prk_derive_secret (pack ("H*", $secret), $length, @info)
}

sub credential {
   my ($self, $purpose, $name, $username) = @_;

   $username = "" unless defined $username;

   $purpose eq "token"
      or die "Unknown credential purpose '$purpose'\n";

   my $credential = MIME::Base64::encode_base64 (
      $self->derive_secret (
         32, $purpose, AnyEvent::MCP::utf8enc (program_name ()),
         AnyEvent::MCP::utf8enc ($name), AnyEvent::MCP::utf8enc ($username)
      ), ""
   );
   $credential =~ y!+/=!-_!d;

   $credential
}

sub program_name {
   my $name = File::Basename::basename ($0);
   $name =~ s/\.(?:pl|perl)\z//;
   $name eq "-e" ? "perl" : $name
}

sub server_name {
   my ($name) = @_;

   $name = "default" unless defined $name;

   $name =~ /\A[A-Za-z_][A-Za-z0-9_-]*\z/
      or die "Invalid MCP server name '$name'\n";

   $name
}

sub http_getopt {
   my ($name, $bind, $print_url, $tokens) = @_;

   "name=s" => $name, "bind=s" => $bind, "print-url" => $print_url, "token=s@" => $tokens
}

sub server_port {
   my ($self, $name) = @_;

   $name = server_name $name;

   16384 + ((unpack "n", $self->derive_secret (2, "port", AnyEvent::MCP::utf8enc (program_name ()), AnyEvent::MCP::utf8enc ($name))) & 16383)
}

sub http_settings {
   my ($self, $name, $bind) = @_;

   $name = server_name $name;
   my $settings = {
      %{ $self->{section}{"program " . program_name ()} },
      %{ $self->{section}{"instance $name"} },
   };
   my $port = $self->server_port ($name);
   my $configured = $settings->{bind} // "127.0.0.1:$port";
   $configured = "127.0.0.1$configured" if $configured =~ /\A:[0-9]+\z/;
   my ($configured_host, $configured_port) = AnyEvent::Socket::parse_hostport $configured, $port;
   defined $configured_host && defined $configured_port
      && $configured_port =~ /\A[0-9]+\z/ && $configured_port <= 65535
      or die "Invalid MCP bind address '$configured'\n";

   $bind = $configured unless defined $bind;
   $bind = "127.0.0.1$bind" if $bind =~ /\A:[0-9]+\z/;

   my ($host, $service) = AnyEvent::Socket::parse_hostport $bind, $configured_port;
   defined $host && defined $service && $service =~ /\A[0-9]+\z/ && $service <= 65535
      or die "Invalid MCP bind address '$bind'\n";

   my %kv = (
      (map { exists $settings->{$_} ? ($_ => $settings->{$_}) : () }
         qw(path url_host url_scheme)),
      name => $name,
      host => $host,
      port => $service,
   );

   unless (AnyEvent::Socket::parse_address $host) {
      my ($error, @addresses) = Socket::getaddrinfo ($host, undef, { socktype => Socket::SOCK_STREAM () });
      !$error && @addresses
         or die "Cannot resolve MCP bind host '$host': $error\n";

      my (undef, $address) = AnyEvent::Socket::unpack_sockaddr $addresses[0]{addr};

      $kv{url_host} //= $host;
      $kv{host} = AnyEvent::Socket::format_address $address;
   }

   $kv{tokens} = [exists $settings->{tokens}
      ? split /\s*,\s*/, $settings->{tokens}, -1
      : $self->credential ("token", $name)];

   %kv
}

sub http_url {
   my ($self, $name, $bind, %options) = @_;

   $name = server_name $name;

   # only a derived token depends on the master secret surviving this process.
   if (($options{auth} || "") ne "none"
      && !exists $options{tokens}
      && !exists $self->{section}{"instance $name"}{tokens}
      && !exists $self->{section}{"program " . program_name ()}{tokens}) {
      my $stored = ref ($self)->new (file => $self->{file});
      $stored->{section}{global}{secret} eq $self->{section}{global}{secret}
         or die "MCP master secret is not persistently stored in $self->{file}\n";
   }

   require AnyEvent::MCP::Server::HTTP;
   my %http = $self->http_settings ($name, $bind);
   delete $http{tokens} if ($options{auth} || "") eq "none";

   AnyEvent::MCP::Server::HTTP->new (%http, %options)->url
}


1
Revision:	1.16
Committed:	Sun Oct 18 18:50:46 2026 UTC (3 weeks, 4 days ago) by root
Branch:	MAIN
Changes since 1.15:	+1 -12 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::MCP::Config - named servers and derived MCP credentials
4
5			=head1 SYNOPSIS
6
7	root	1.12	use AnyEvent::MCP::Config;
8
9	root	1.1	my $config = AnyEvent::MCP::Config->global;
10	root	1.8	my $token = $config->credential ("token", "agni");
11	root	1.6	my $url = $config->http_url ("agni", undef, path => "/");
12	root	1.1
13			=head1 DESCRIPTION
14
15	root	1.3	An MCP server and its clients often need matching credentials. Rather than
16			maintaining a separate password for each server and user, this module can
17	root	1.14	derive them from one private master secret. The invoked program basename,
18			instance name, optional username and credential purpose each contribute to
19			the result. Instances default to C<default>; different programs still derive
20			different credentials for that instance name.
21	root	1.3
22			The shared file format is described in L<AnyEvent::MCP/GLOBAL CONFIGURATION>.
23			Loading this module does not read any files. The first call to C<global>
24			reads the configuration, ensures a master secret exists and caches the object
25			for the process.
26	root	1.1
27			A missing secret is generated using C<AnyEvent::MCP::random_bytes> and saved
28			when possible. Saving failure produces a warning; the generated secret remains
29	root	1.3	usable in this process, but another process might derive different credentials.
30			A supplied invalid secret is an error. Changing or losing the master secret
31			invalidates all credentials derived from it.
32	root	1.1
33	root	1.13	Derivation uses C<derive_secret> with the random master key.
34	root	1.14	The application namespace, purpose, program, instance name and username are
35			separately length-prefixed, so distinct contexts derive different credentials.
36	root	1.3	Deriving a password does not create an account or configure the server to
37			accept it: authentication still belongs to the server.
38	root	1.1
39			=head1 METHODS
40
41	root	1.12	=over
42
43			=item $config = AnyEvent::MCP::Config->global (file => $file)
44	root	1.1
45			Returns the cached global configuration. The first call accepts the same
46			arguments as C<new>; later calls return the same object without rereading
47			the file. Call this explicitly during program startup.
48
49	root	1.12	=item $config = AnyEvent::MCP::Config->new (file => $file)
50	root	1.1
51			Reads C<$file>, or the default file when omitted, and ensures a master
52			secret exists. Unlike C<global>, each call creates an independent object.
53			A missing file is allowed; other read errors are fatal. Sections are available
54			as C<< $config->{section}{$section} >>, each a hash reference of string
55	root	1.10	values. Named servers use C<[instance NAME]>.
56	root	1.1
57	root	1.12	=item $config = AnyEvent::MCP::Config->init (file => $file)
58	root	1.1
59			Explicitly creates the configuration file with a random secret, mode 0600.
60			Creates missing parent directories with mode 0700. Fails if the file already
61			exists, so it cannot accidentally replace an existing secret.
62
63	root	1.13	=item $bytes = $config->derive_secret ($length, @info)
64
65			=item $bytes = AnyEvent::MCP::Config->derive_secret ($length, @info)
66
67			Derive C<$length> secret bytes from the configuration's master secret and
68			an ordered list of context byte strings C<@info>. The class form uses
69			C<global>, loading the default configuration on first use and reusing it
70			thereafter. The object form uses that object's configuration, including
71			one loaded from an explicit file.
72
73			The same master secret and context always produce the same bytes. Use a
74			distinctive application/purpose string as the first context field, followed
75			by names or other values identifying the result:
76
77			my $secret = AnyEvent::MCP::Config->derive_secret (
78			32, "my application token v1", AnyEvent::MCP::utf8enc ($name)
79			);
80
81			The result contains raw bytes; encode it yourself if a printable token is
82			needed. This method does not add the result to a server's accepted tokens.
83
84	root	1.14	The fixed C<anyevent-mcp> context field is prepended automatically.
85	root	1.13	Context fields are separately length-prefixed, so C<("ab", "c")> and
86			C<("a", "bc")> have different contexts. Encode character strings explicitly,
87			for example with C<AnyEvent::MCP::utf8enc>. Context arguments are left
88			unchanged.
89
90			C<$length> must be an integer in 0..16320; zero returns an empty string.
91			Shorter results are prefixes of longer results for the same master secret
92			and context. Use distinct context fields for different purposes, rather
93			than relying on different lengths to separate them.
94
95			Derivation uses HKDF-SHA512 expansion, with each context field prefixed by
96			its four-byte big-endian byte length. Changing or losing the master secret
97			changes every result derived from it.
98
99	root	1.12	=item $credential = $config->credential ($purpose, $name, $username)
100	root	1.1
101			Derives a 32-byte credential, returned as unpadded URL-safe Base64.
102	root	1.14	C<$purpose> is C<token>. C<$name> is the instance name, and C<$username>
103	root	1.8	is optional. The default server credential is derived with no username.
104	root	1.1
105	root	1.14	Credentials use the context C<("anyevent-mcp", "token", PROGRAM, NAME, USER)>.
106			PROGRAM is the invoked basename, with a trailing C<.pl> or C<.perl> removed.
107			Changing the program or instance name changes the credential. This derivation
108			replaces the older name-only context; update stored client URLs.
109	root	1.12	A credential derived with C<$username> is B<not> automatically accepted
110			by the server. This method neither requires a server section nor configures
111			authentication.
112	root	1.1
113	root	1.14	=item $program = AnyEvent::MCP::Config::program_name ()
114
115			Returns the invoked program basename, stripping C<.pl> or C<.perl>.
116			An inline Perl invocation uses C<perl>. This identity also selects the
117			C<[program PROGRAM]> configuration section; it is independent of routing aliases.
118
119	root	1.12	=item $name = AnyEvent::MCP::Config::server_name ($name)
120	root	1.4
121	root	1.14	Validate a service-instance name, or use C<default> if undefined.
122	root	1.4	Names consist of an ASCII letter or underscore followed by letters, digits,
123			underscores or hyphens.
124
125	root	1.12	=item @options = AnyEvent::MCP::Config::http_getopt (\$name, \$bind, \$print_url, \@tokens)
126	root	1.4
127			Return standard C<Getopt::Long> options referring to the caller's scalars.
128
129	root	1.12	=item $port = $config->server_port ($name)
130	root	1.4
131			Derive a stable default port in 16384..32767 from the master secret and
132	root	1.14	program basename and service-instance name. Collisions produce ordinary listener bind errors.
133	root	1.4
134	root	1.12	=item %settings = $config->http_settings ($name, $bind)
135	root	1.4
136	root	1.10	Resolve HTTP settings from C<[instance NAME]> and an optional command-line
137	root	1.4	C<bind> override. The default is IPv4 loopback and the name-derived port.
138			The bind setting accepts C<ADDRESS:PORT>, C<[IPv6]:PORT>, C<ADDRESS>,
139			and C<:PORT> (which keeps the default loopback address).
140	root	1.12	Hostnames are resolved once when settings are obtained; their original
141			spelling is advertised unless C<url_host> overrides it. The returned options
142			include C<name>, C<host>, C<port> and C<tokens>, plus configured C<path>,
143			C<url_host> and C<url_scheme>. This does not start a listener.
144	root	1.4
145	root	1.12	=item $url = $config->http_url ($name, $bind, %options)
146	root	1.4
147	root	1.8	Format a URL containing the first accepted token, without listening.
148			Port zero cannot be used because the kernel has not yet selected a port.
149			When the token is derived, the master secret must be persistently stored,
150			so the next process derives the same URL. Explicit static tokens and
151			C<auth =E<gt> "none"> do not require that persistence check.
152	root	1.4
153	root	1.12	=back
154
155	root	1.1	=cut
156
157			package AnyEvent::MCP::Config;
158
159			use common::sense;
160			use AnyEvent::MCP ();
161	root	1.13	use Digest::SHA ();
162	root	1.1	use MIME::Base64 ();
163			use File::Basename ();
164			use File::Path ();
165			use Fcntl qw(O_WRONLY O_RDWR O_CREAT O_EXCL LOCK_EX);
166			use Errno qw(ENOENT);
167	root	1.4	use AnyEvent::Socket ();
168			use Socket ();
169	root	1.1
170			our @ISA = qw(AnyEvent::MCP::Base);
171
172			sub _file {
173			my $dir = $ENV{XDG_CONFIG_HOME}
174			\|\| ($ENV{HOME} \|\| die "HOME is not set\n") . "/.config";
175
176			"$dir/anyevent-mcp/global.ini"
177			}
178
179			my $global;
180
181			sub global {
182			my $class = shift;
183
184			$global \|\|= $class->new (@_)
185			}
186
187	root	1.16	sub new {
188	root	1.1	my ($class, %kv) = @_;
189	root	1.11
190	root	1.1	my $self = $class->SUPER::new (section => {}, %kv);
191			$self->{file} = _file unless exists $self->{file};
192
193			if (open my $fh, "<:encoding(UTF-8)", $self->{file}) {
194			$self->_read ($fh);
195			close $fh or die "$self->{file}: $!\n";
196			} else {
197			die "$self->{file}: $!\n" unless $! == ENOENT;
198			}
199
200			$self->_ensure_secret;
201
202	root	1.11	$self->{section}{global}{secret} =~ /\A[0-9a-fA-F]{128}\z/
203			or die "$self->{file}: invalid secret; supply 128 hexadecimal digits\n";
204	root	1.1
205			$self
206			}
207
208			sub _read {
209			my ($self, $fh) = @_;
210
211			my @stat = stat $fh;
212			die "$self->{file}: configuration must be private and owned by this user\n"
213			if $stat[4] != $< \|\| $stat[2] & 077;
214
215	root	1.15	local $/;
216			AnyEvent::MCP::parse_ini scalar (<$fh>), sub {
217			my ($name, $kv) = @_;
218			my $section = $self->{section}{$name \|\| "global"} \|\|= {};
219			%$section = (%$section, %$kv);
220			}, $self->{file};
221	root	1.1
222			}
223
224			sub _ensure_secret {
225			my ($self) = @_;
226
227			return if exists $self->{section}{global}{secret};
228
229			my $secret = eval { unpack "H*", AnyEvent::MCP::random_bytes 64 };
230			die "$@Supply a securely generated 128-digit hexadecimal secret in $self->{file}\n"
231			if $@;
232
233			eval {
234			File::Path::mkpath (File::Basename::dirname ($self->{file}), 0, 0700);
235			sysopen my $fh, $self->{file}, O_RDWR \| O_CREAT, 0600
236			or die "$self->{file}: $!\n";
237			flock $fh, LOCK_EX or die "$self->{file}: $!\n";
238			binmode $fh, ":encoding(UTF-8)";
239
240			my $disk = bless { file => $self->{file}, section => {} }, ref $self;
241			$disk->_read ($fh);
242
243			unless (exists $disk->{section}{global}{secret}) {
244			seek $fh, 0, 2 or die "$self->{file}: $!\n";
245			print {$fh} "\n[global]\nsecret = $secret\n"
246			or die "$self->{file}: $!\n";
247			$disk->{section}{global}{secret} = $secret;
248			}
249
250			close $fh or die "$self->{file}: $!\n";
251			$self->{section} = $disk->{section};
252			1
253			} or warn "Cannot save MCP master secret; credentials may only be stable for this process: $@";
254
255			$self->{section}{global}{secret} = $secret
256			unless exists $self->{section}{global}{secret};
257			}
258
259			sub init {
260			my ($class, %kv) = @_;
261	root	1.11
262	root	1.1	my $file = exists $kv{file} ? $kv{file} : _file;
263
264			my $secret = AnyEvent::MCP::random_bytes 64;
265
266			File::Path::mkpath (File::Basename::dirname ($file), 0, 0700);
267
268			sysopen my $fh, $file, O_WRONLY \| O_CREAT \| O_EXCL, 0600
269			or die "$file: $!\n";
270
271			print {$fh} "[global]\nsecret = ", unpack ("H*", $secret), "\n"
272			or die "$file: $!\n";
273			close $fh or die "$file: $!\n";
274
275			$class->new (file => $file)
276			}
277
278	root	1.13	sub _prk_derive_secret($$@) {
279			my ($prk, $length, @info) = @_;
280
281			64 == length $prk
282			or die "derive_secret: key length must be 64 octets\n";
283			$length =~ /\A[0-9]+\z/ && $length <= 255 * 64
284			or die "derive_secret: length must be an integer in 0..16320\n";
285
286	root	1.14	my $info = pack "(N/a)", "anyevent-mcp", @info;
287	root	1.13	my $t = "";
288			my $okm = "";
289			my $i = 0;
290
291			while ($length > length $okm) {
292			$t = Digest::SHA::hmac_sha512 $t . $info . chr ++$i, $prk;
293			$okm .= $t;
294			}
295
296			substr $okm, 0, $length
297			}
298
299			sub derive_secret {
300			my ($self, $length, @info) = @_;
301
302			$self = $self->global unless ref $self;
303
304			my $secret = $self->{section}{global}{secret};
305			$secret =~ /\A[0-9a-fA-F]{128}\z/
306			or die "$self->{file}: missing or invalid secret\n";
307
308			_prk_derive_secret (pack ("H*", $secret), $length, @info)
309			}
310
311	root	1.1	sub credential {
312			my ($self, $purpose, $name, $username) = @_;
313
314			$username = "" unless defined $username;
315
316	root	1.11	$purpose eq "token"
317			or die "Unknown credential purpose '$purpose'\n";
318	root	1.1
319			my $credential = MIME::Base64::encode_base64 (
320	root	1.13	$self->derive_secret (
321	root	1.14	32, $purpose, AnyEvent::MCP::utf8enc (program_name ()),
322	root	1.13	AnyEvent::MCP::utf8enc ($name), AnyEvent::MCP::utf8enc ($username)
323			), ""
324	root	1.1	);
325			$credential =~ y!+/=!-_!d;
326
327			$credential
328			}
329
330	root	1.14	sub program_name {
331			my $name = File::Basename::basename ($0);
332			$name =~ s/\.(?:pl\|perl)\z//;
333			$name eq "-e" ? "perl" : $name
334			}
335
336	root	1.4	sub server_name {
337			my ($name) = @_;
338
339	root	1.14	$name = "default" unless defined $name;
340	root	1.4
341			$name =~ /\A[A-Za-z_][A-Za-z0-9_-]*\z/
342			or die "Invalid MCP server name '$name'\n";
343
344			$name
345			}
346
347			sub http_getopt {
348	root	1.5	my ($name, $bind, $print_url, $tokens) = @_;
349	root	1.4
350	root	1.5	"name=s" => $name, "bind=s" => $bind, "print-url" => $print_url, "token=s@" => $tokens
351	root	1.4	}
352
353			sub server_port {
354			my ($self, $name) = @_;
355
356			$name = server_name $name;
357
358	root	1.14	16384 + ((unpack "n", $self->derive_secret (2, "port", AnyEvent::MCP::utf8enc (program_name ()), AnyEvent::MCP::utf8enc ($name))) & 16383)
359	root	1.4	}
360
361			sub http_settings {
362			my ($self, $name, $bind) = @_;
363
364			$name = server_name $name;
365	root	1.14	my $settings = {
366			%{ $self->{section}{"program " . program_name ()} },
367			%{ $self->{section}{"instance $name"} },
368			};
369	root	1.4	my $port = $self->server_port ($name);
370			my $configured = $settings->{bind} // "127.0.0.1:$port";
371			$configured = "127.0.0.1$configured" if $configured =~ /\A:[0-9]+\z/;
372			my ($configured_host, $configured_port) = AnyEvent::Socket::parse_hostport $configured, $port;
373			defined $configured_host && defined $configured_port
374			&& $configured_port =~ /\A[0-9]+\z/ && $configured_port <= 65535
375			or die "Invalid MCP bind address '$configured'\n";
376
377			$bind = $configured unless defined $bind;
378			$bind = "127.0.0.1$bind" if $bind =~ /\A:[0-9]+\z/;
379
380			my ($host, $service) = AnyEvent::Socket::parse_hostport $bind, $configured_port;
381			defined $host && defined $service && $service =~ /\A[0-9]+\z/ && $service <= 65535
382			or die "Invalid MCP bind address '$bind'\n";
383
384			my %kv = (
385			(map { exists $settings->{$_} ? ($_ => $settings->{$_}) : () }
386	root	1.5	qw(path url_host url_scheme)),
387	root	1.4	name => $name,
388			host => $host,
389			port => $service,
390			);
391
392			unless (AnyEvent::Socket::parse_address $host) {
393			my ($error, @addresses) = Socket::getaddrinfo ($host, undef, { socktype => Socket::SOCK_STREAM () });
394			!$error && @addresses
395			or die "Cannot resolve MCP bind host '$host': $error\n";
396
397	root	1.9	my (undef, $address) = AnyEvent::Socket::unpack_sockaddr $addresses[0]{addr};
398	root	1.4
399			$kv{url_host} //= $host;
400	root	1.9	$kv{host} = AnyEvent::Socket::format_address $address;
401	root	1.4	}
402
403	root	1.11	$kv{tokens} = [exists $settings->{tokens}
404			? split /\s,\s/, $settings->{tokens}, -1
405			: $self->credential ("token", $name)];
406	root	1.4
407			%kv
408			}
409
410			sub http_url {
411			my ($self, $name, $bind, %options) = @_;
412
413	root	1.14	$name = server_name $name;
414
415	root	1.11	# only a derived token depends on the master secret surviving this process.
416	root	1.8	if (($options{auth} \|\| "") ne "none"
417			&& !exists $options{tokens}
418	root	1.14	&& !exists $self->{section}{"instance $name"}{tokens}
419			&& !exists $self->{section}{"program " . program_name ()}{tokens}) {
420	root	1.8	my $stored = ref ($self)->new (file => $self->{file});
421			$stored->{section}{global}{secret} eq $self->{section}{global}{secret}
422			or die "MCP master secret is not persistently stored in $self->{file}\n";
423			}
424	root	1.4
425			require AnyEvent::MCP::Server::HTTP;
426	root	1.8	my %http = $self->http_settings ($name, $bind);
427			delete $http{tokens} if ($options{auth} \|\| "") eq "none";
428	root	1.11
429			AnyEvent::MCP::Server::HTTP->new (%http, %options)->url
430	root	1.4	}
431
432	root	1.1
433			1