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.
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 @rules = $config->auto_rules ($name)

Return ordered automatic permission rules from C<[program PROGRAM]> and
C<[instance NAME]>. C<auto-rule.SUFFIX = allow|deny TOOL[,ACTION[,CAPABILITY]]>
entries are sorted by key. The suffix is an arbitrary ordering label; instance
entries override matching program entries, and an empty value disables an
inherited entry. Command-line rules take precedence over these defaults.

=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 auto_rules {
   my ($self, $name) = @_;
   my %settings = (
      %{$self->{section}{"program " . program_name ()} || {}},
      %{$self->{section}{"instance " . server_name ($name)} || {}},
   );
   my @rules;

   for my $key (sort grep /\Aauto-rule\./, keys %settings) {
      $key =~ /\Aauto-rule\.(.+)\z/
         or die "Invalid automatic permission rule key '$key'\n";
      my $value = $settings{$key};
      next unless length $value;
      my ($decision, $spec) = $value =~ /\A(allow|deny)\s+(\S+)\z/
         or die "Invalid configured automatic permission rule '$key'\n";
      push @rules, [$decision, $spec];
   }

   @rules
}

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.18
Committed:	Wed Oct 21 17:28:16 2026 UTC (3 weeks, 1 day ago) by root
Branch:	MAIN
CVS Tags:	rel-0_6
Changes since 1.17:	+1 -2 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	root	1.18	Changing the program or instance name changes the credential.
108	root	1.12	A credential derived with C<$username> is B<not> automatically accepted
109			by the server. This method neither requires a server section nor configures
110			authentication.
111	root	1.1
112	root	1.14	=item $program = AnyEvent::MCP::Config::program_name ()
113
114			Returns the invoked program basename, stripping C<.pl> or C<.perl>.
115			An inline Perl invocation uses C<perl>. This identity also selects the
116			C<[program PROGRAM]> configuration section; it is independent of routing aliases.
117
118	root	1.12	=item $name = AnyEvent::MCP::Config::server_name ($name)
119	root	1.4
120	root	1.14	Validate a service-instance name, or use C<default> if undefined.
121	root	1.4	Names consist of an ASCII letter or underscore followed by letters, digits,
122			underscores or hyphens.
123
124	root	1.12	=item @options = AnyEvent::MCP::Config::http_getopt (\$name, \$bind, \$print_url, \@tokens)
125	root	1.4
126			Return standard C<Getopt::Long> options referring to the caller's scalars.
127
128	root	1.12	=item $port = $config->server_port ($name)
129	root	1.4
130			Derive a stable default port in 16384..32767 from the master secret and
131	root	1.14	program basename and service-instance name. Collisions produce ordinary listener bind errors.
132	root	1.4
133	root	1.12	=item %settings = $config->http_settings ($name, $bind)
134	root	1.4
135	root	1.10	Resolve HTTP settings from C<[instance NAME]> and an optional command-line
136	root	1.4	C<bind> override. The default is IPv4 loopback and the name-derived port.
137			The bind setting accepts C<ADDRESS:PORT>, C<[IPv6]:PORT>, C<ADDRESS>,
138			and C<:PORT> (which keeps the default loopback address).
139	root	1.12	Hostnames are resolved once when settings are obtained; their original
140			spelling is advertised unless C<url_host> overrides it. The returned options
141			include C<name>, C<host>, C<port> and C<tokens>, plus configured C<path>,
142			C<url_host> and C<url_scheme>. This does not start a listener.
143	root	1.4
144	root	1.17	=item @rules = $config->auto_rules ($name)
145
146			Return ordered automatic permission rules from C<[program PROGRAM]> and
147			C<[instance NAME]>. C<auto-rule.SUFFIX = allow\|deny TOOL[,ACTION[,CAPABILITY]]>
148			entries are sorted by key. The suffix is an arbitrary ordering label; instance
149			entries override matching program entries, and an empty value disables an
150			inherited entry. Command-line rules take precedence over these defaults.
151
152	root	1.12	=item $url = $config->http_url ($name, $bind, %options)
153	root	1.4
154	root	1.8	Format a URL containing the first accepted token, without listening.
155			Port zero cannot be used because the kernel has not yet selected a port.
156			When the token is derived, the master secret must be persistently stored,
157			so the next process derives the same URL. Explicit static tokens and
158			C<auth =E<gt> "none"> do not require that persistence check.
159	root	1.4
160	root	1.12	=back
161
162	root	1.1	=cut
163
164			package AnyEvent::MCP::Config;
165
166			use common::sense;
167			use AnyEvent::MCP ();
168	root	1.13	use Digest::SHA ();
169	root	1.1	use MIME::Base64 ();
170			use File::Basename ();
171			use File::Path ();
172			use Fcntl qw(O_WRONLY O_RDWR O_CREAT O_EXCL LOCK_EX);
173			use Errno qw(ENOENT);
174	root	1.4	use AnyEvent::Socket ();
175			use Socket ();
176	root	1.1
177			our @ISA = qw(AnyEvent::MCP::Base);
178
179			sub _file {
180			my $dir = $ENV{XDG_CONFIG_HOME}
181			\|\| ($ENV{HOME} \|\| die "HOME is not set\n") . "/.config";
182
183			"$dir/anyevent-mcp/global.ini"
184			}
185
186			my $global;
187
188			sub global {
189			my $class = shift;
190
191			$global \|\|= $class->new (@_)
192			}
193
194	root	1.16	sub new {
195	root	1.1	my ($class, %kv) = @_;
196	root	1.11
197	root	1.1	my $self = $class->SUPER::new (section => {}, %kv);
198			$self->{file} = _file unless exists $self->{file};
199
200			if (open my $fh, "<:encoding(UTF-8)", $self->{file}) {
201			$self->_read ($fh);
202			close $fh or die "$self->{file}: $!\n";
203			} else {
204			die "$self->{file}: $!\n" unless $! == ENOENT;
205			}
206
207			$self->_ensure_secret;
208
209	root	1.11	$self->{section}{global}{secret} =~ /\A[0-9a-fA-F]{128}\z/
210			or die "$self->{file}: invalid secret; supply 128 hexadecimal digits\n";
211	root	1.1
212			$self
213			}
214
215			sub _read {
216			my ($self, $fh) = @_;
217
218			my @stat = stat $fh;
219			die "$self->{file}: configuration must be private and owned by this user\n"
220			if $stat[4] != $< \|\| $stat[2] & 077;
221
222	root	1.15	local $/;
223			AnyEvent::MCP::parse_ini scalar (<$fh>), sub {
224			my ($name, $kv) = @_;
225			my $section = $self->{section}{$name \|\| "global"} \|\|= {};
226			%$section = (%$section, %$kv);
227			}, $self->{file};
228	root	1.1
229			}
230
231			sub _ensure_secret {
232			my ($self) = @_;
233
234			return if exists $self->{section}{global}{secret};
235
236			my $secret = eval { unpack "H*", AnyEvent::MCP::random_bytes 64 };
237			die "$@Supply a securely generated 128-digit hexadecimal secret in $self->{file}\n"
238			if $@;
239
240			eval {
241			File::Path::mkpath (File::Basename::dirname ($self->{file}), 0, 0700);
242			sysopen my $fh, $self->{file}, O_RDWR \| O_CREAT, 0600
243			or die "$self->{file}: $!\n";
244			flock $fh, LOCK_EX or die "$self->{file}: $!\n";
245			binmode $fh, ":encoding(UTF-8)";
246
247			my $disk = bless { file => $self->{file}, section => {} }, ref $self;
248			$disk->_read ($fh);
249
250			unless (exists $disk->{section}{global}{secret}) {
251			seek $fh, 0, 2 or die "$self->{file}: $!\n";
252			print {$fh} "\n[global]\nsecret = $secret\n"
253			or die "$self->{file}: $!\n";
254			$disk->{section}{global}{secret} = $secret;
255			}
256
257			close $fh or die "$self->{file}: $!\n";
258			$self->{section} = $disk->{section};
259			1
260			} or warn "Cannot save MCP master secret; credentials may only be stable for this process: $@";
261
262			$self->{section}{global}{secret} = $secret
263			unless exists $self->{section}{global}{secret};
264			}
265
266			sub init {
267			my ($class, %kv) = @_;
268	root	1.11
269	root	1.1	my $file = exists $kv{file} ? $kv{file} : _file;
270
271			my $secret = AnyEvent::MCP::random_bytes 64;
272
273			File::Path::mkpath (File::Basename::dirname ($file), 0, 0700);
274
275			sysopen my $fh, $file, O_WRONLY \| O_CREAT \| O_EXCL, 0600
276			or die "$file: $!\n";
277
278			print {$fh} "[global]\nsecret = ", unpack ("H*", $secret), "\n"
279			or die "$file: $!\n";
280			close $fh or die "$file: $!\n";
281
282			$class->new (file => $file)
283			}
284
285	root	1.13	sub _prk_derive_secret($$@) {
286			my ($prk, $length, @info) = @_;
287
288			64 == length $prk
289			or die "derive_secret: key length must be 64 octets\n";
290			$length =~ /\A[0-9]+\z/ && $length <= 255 * 64
291			or die "derive_secret: length must be an integer in 0..16320\n";
292
293	root	1.14	my $info = pack "(N/a)", "anyevent-mcp", @info;
294	root	1.13	my $t = "";
295			my $okm = "";
296			my $i = 0;
297
298			while ($length > length $okm) {
299			$t = Digest::SHA::hmac_sha512 $t . $info . chr ++$i, $prk;
300			$okm .= $t;
301			}
302
303			substr $okm, 0, $length
304			}
305
306			sub derive_secret {
307			my ($self, $length, @info) = @_;
308
309			$self = $self->global unless ref $self;
310
311			my $secret = $self->{section}{global}{secret};
312			$secret =~ /\A[0-9a-fA-F]{128}\z/
313			or die "$self->{file}: missing or invalid secret\n";
314
315			_prk_derive_secret (pack ("H*", $secret), $length, @info)
316			}
317
318	root	1.1	sub credential {
319			my ($self, $purpose, $name, $username) = @_;
320
321			$username = "" unless defined $username;
322
323	root	1.11	$purpose eq "token"
324			or die "Unknown credential purpose '$purpose'\n";
325	root	1.1
326			my $credential = MIME::Base64::encode_base64 (
327	root	1.13	$self->derive_secret (
328	root	1.14	32, $purpose, AnyEvent::MCP::utf8enc (program_name ()),
329	root	1.13	AnyEvent::MCP::utf8enc ($name), AnyEvent::MCP::utf8enc ($username)
330			), ""
331	root	1.1	);
332			$credential =~ y!+/=!-_!d;
333
334			$credential
335			}
336
337	root	1.14	sub program_name {
338			my $name = File::Basename::basename ($0);
339			$name =~ s/\.(?:pl\|perl)\z//;
340			$name eq "-e" ? "perl" : $name
341			}
342
343	root	1.4	sub server_name {
344			my ($name) = @_;
345
346	root	1.14	$name = "default" unless defined $name;
347	root	1.4
348			$name =~ /\A[A-Za-z_][A-Za-z0-9_-]*\z/
349			or die "Invalid MCP server name '$name'\n";
350
351			$name
352			}
353
354			sub http_getopt {
355	root	1.5	my ($name, $bind, $print_url, $tokens) = @_;
356	root	1.4
357	root	1.5	"name=s" => $name, "bind=s" => $bind, "print-url" => $print_url, "token=s@" => $tokens
358	root	1.4	}
359
360	root	1.17	sub auto_rules {
361			my ($self, $name) = @_;
362			my %settings = (
363			%{$self->{section}{"program " . program_name ()} \|\| {}},
364			%{$self->{section}{"instance " . server_name ($name)} \|\| {}},
365			);
366			my @rules;
367
368			for my $key (sort grep /\Aauto-rule\./, keys %settings) {
369			$key =~ /\Aauto-rule\.(.+)\z/
370			or die "Invalid automatic permission rule key '$key'\n";
371			my $value = $settings{$key};
372			next unless length $value;
373			my ($decision, $spec) = $value =~ /\A(allow\|deny)\s+(\S+)\z/
374			or die "Invalid configured automatic permission rule '$key'\n";
375			push @rules, [$decision, $spec];
376			}
377
378			@rules
379			}
380
381	root	1.4	sub server_port {
382			my ($self, $name) = @_;
383
384			$name = server_name $name;
385
386	root	1.14	16384 + ((unpack "n", $self->derive_secret (2, "port", AnyEvent::MCP::utf8enc (program_name ()), AnyEvent::MCP::utf8enc ($name))) & 16383)
387	root	1.4	}
388
389			sub http_settings {
390			my ($self, $name, $bind) = @_;
391
392			$name = server_name $name;
393	root	1.14	my $settings = {
394			%{ $self->{section}{"program " . program_name ()} },
395			%{ $self->{section}{"instance $name"} },
396			};
397	root	1.4	my $port = $self->server_port ($name);
398			my $configured = $settings->{bind} // "127.0.0.1:$port";
399			$configured = "127.0.0.1$configured" if $configured =~ /\A:[0-9]+\z/;
400			my ($configured_host, $configured_port) = AnyEvent::Socket::parse_hostport $configured, $port;
401			defined $configured_host && defined $configured_port
402			&& $configured_port =~ /\A[0-9]+\z/ && $configured_port <= 65535
403			or die "Invalid MCP bind address '$configured'\n";
404
405			$bind = $configured unless defined $bind;
406			$bind = "127.0.0.1$bind" if $bind =~ /\A:[0-9]+\z/;
407
408			my ($host, $service) = AnyEvent::Socket::parse_hostport $bind, $configured_port;
409			defined $host && defined $service && $service =~ /\A[0-9]+\z/ && $service <= 65535
410			or die "Invalid MCP bind address '$bind'\n";
411
412			my %kv = (
413			(map { exists $settings->{$_} ? ($_ => $settings->{$_}) : () }
414	root	1.5	qw(path url_host url_scheme)),
415	root	1.4	name => $name,
416			host => $host,
417			port => $service,
418			);
419
420			unless (AnyEvent::Socket::parse_address $host) {
421			my ($error, @addresses) = Socket::getaddrinfo ($host, undef, { socktype => Socket::SOCK_STREAM () });
422			!$error && @addresses
423			or die "Cannot resolve MCP bind host '$host': $error\n";
424
425	root	1.9	my (undef, $address) = AnyEvent::Socket::unpack_sockaddr $addresses[0]{addr};
426	root	1.4
427			$kv{url_host} //= $host;
428	root	1.9	$kv{host} = AnyEvent::Socket::format_address $address;
429	root	1.4	}
430
431	root	1.11	$kv{tokens} = [exists $settings->{tokens}
432			? split /\s,\s/, $settings->{tokens}, -1
433			: $self->credential ("token", $name)];
434	root	1.4
435			%kv
436			}
437
438			sub http_url {
439			my ($self, $name, $bind, %options) = @_;
440
441	root	1.14	$name = server_name $name;
442
443	root	1.11	# only a derived token depends on the master secret surviving this process.
444	root	1.8	if (($options{auth} \|\| "") ne "none"
445			&& !exists $options{tokens}
446	root	1.14	&& !exists $self->{section}{"instance $name"}{tokens}
447			&& !exists $self->{section}{"program " . program_name ()}{tokens}) {
448	root	1.8	my $stored = ref ($self)->new (file => $self->{file});
449			$stored->{section}{global}{secret} eq $self->{section}{global}{secret}
450			or die "MCP master secret is not persistently stored in $self->{file}\n";
451			}
452	root	1.4
453			require AnyEvent::MCP::Server::HTTP;
454	root	1.8	my %http = $self->http_settings ($name, $bind);
455			delete $http{tokens} if ($options{auth} \|\| "") eq "none";
456	root	1.11
457			AnyEvent::MCP::Server::HTTP->new (%http, %options)->url
458	root	1.4	}
459
460	root	1.1
461			1