lib/App/FileSync/Transport/SSH.pm — Duplicate Code Regions
◆ Amber lines duplicate code in another file — hover for location. ◆ Purple: duplicate of another region within this same file.
1: package App::FileSync::Transport::SSH;
2:
3: # Runs filesync-server on the server host over one ssh connection and speaks
4: # the wire protocol on its pipes. The ssh argument list is built here and
5: # never passed through a local shell, and every value that reaches the remote
6: # shell is restricted to characters that are inert there, so a repo or client
7: # id cannot become a command.
8:
9: use App::FileSync::Platform;
10:
11: use strict;
12: use warnings;
13:
14: # Not :all - this class has a close method, and autodie replaces a package's
15: # subs named after the builtins it wraps.
16: use autodie qw(open);
17:
18: use File::Temp ();
19: use IPC::Open3 ();
20: use List::Util qw(any);
21: use Readonly;
22: use Sub::Private { mode => 'enforce' };
23:
24: use App::FileSync qw(validate_client_id validate_repo_name);
25: use App::FileSync::Args qw(named);
26: use App::FileSync::Constants qw($PROTOCOL_VERSION $ROLE_CLIENT @ROLES $SERVER_PROGRAM);
27: use App::FileSync::I18N qw(throw);
28: use App::FileSync::IO qw(read_text);
29:
30: use version; our $VERSION = version->declare('0.001.1');
31:
32: # Kept for compatibility: the protocol version sent as --proto.
33: our $PROTO = $PROTOCOL_VERSION;
34:
35: # Options every session uses: no prompts, keepalives so a dead link is
36: # noticed, and a bounded connect.
37: Readonly my @SSH_OPTIONS => (
38: '-T',
39: '-o', 'BatchMode=yes',
40: '-o', 'ServerAliveInterval=30',
41: '-o', 'ConnectTimeout=10',
42: );
43:
44: # Host key policies a repo may choose.
45: Readonly my @HOST_KEY_CHECKING => qw(yes accept-new);
46:
47: # The highest TCP port.
48: Readonly my $MAX_PORT => 65_535;
49:
50: # Characters that would end or split an argument.
51: Readonly my $UNSAFE_ARG => qr/[\0\n]/;
52:
53: # user@host, host, or a bracketed IPv6 literal. Both the user and the host
54: # start with a letter or digit, so neither can be read as an ssh option.
55: Readonly my $SERVER => qr/\A(?:[A-Za-z0-9][A-Za-z0-9._-]*@)?
56: (?:[A-Za-z0-9](?:[A-Za-z0-9._-]*[A-Za-z0-9])?|\[[0-9A-Fa-f:]+\])\z/x;
57:
58: # A remote program path: only characters inert in a POSIX shell, and not
59: # starting with '-'.
60: Readonly my $PROGRAM => qr{\A[A-Za-z0-9._/][A-Za-z0-9._/-]*\z};
61:
62: =encoding utf8
63:
64: =head1 NAME
65:
66: App::FileSync::Transport::SSH - run the server over ssh
67:
68: =head1 SYNOPSIS
69:
70: my $transport = App::FileSync::Transport::SSH->new(
71: server => 'filesync@files.example.com', repo => 'docs', client => 'laptop',
72: identity => '~/.ssh/filesync_ed25519',
73: );
74: ...
75: $transport->close or warn $transport->error_text;
76:
77: =head1 METHODS
78:
79: =head2 new
80:
81: Purpose: start C<filesync-server> on the server host for one session.
82:
83: Args: C<server> (C<user@host>, C<host> or C<user@[v6]>), C<repo>, C<client>,
84: optional C<role> (default C<client>), C<server_command> (default
85: C<filesync-server>), C<host_key_checking> (C<yes>, the default, or
86: C<accept-new>), C<known_hosts>, C<identity>, C<port>, C<command> (the local
87: ssh program), C<extra_args> (arrayref of extra ssh arguments).
88:
89: Returns: the transport.
90:
91: Side Effects: runs C<ssh ... SERVER PROGRAM --repo R --client C --role X
92: --proto 2>. ssh's standard error goes to a temporary file, never the
93: protocol pipe, and is available from L</error_text>. On Windows a C<.cmd> or
94: C<.bat> ssh wrapper is started through C<COMSPEC>, since CreateProcess cannot
95: start one directly.
96:
97: Usage:
98:
99: my $transport = App::FileSync::Transport::SSH->new(%args);
100:
101: =head3 EXAMPLE
102:
103: my $t = App::FileSync::Transport::SSH->new(
104: server => 'backup', repo => 'photos', client => 'nas', role => 'replica', port => 2222,
105: );
106: print join(' ', @{ $t->command }), "\n";
107:
108: =head3 API SPECIFICATION
109:
110: =head4 INPUT
111:
112: {
113: server => { type => 'string', matches => $SERVER },
114: repo => { type => 'string', min => 1, max => 64 },
115: client => { type => 'string', min => 1, max => 64 },
116: role => { type => 'string', optional => 1, memberof => [ 'client', 'replica' ] },
117: server_command => { type => 'string', optional => 1, matches => $PROGRAM },
118: host_key_checking => { type => 'string', optional => 1, memberof => [ 'yes', 'accept-new' ] },
119: known_hosts => { type => 'string', optional => 1 },
120: identity => { type => 'string', optional => 1 },
121: port => { type => 'integer', optional => 1, min => 1, max => 65535 },
122: command => { type => 'string', optional => 1 },
123: extra_args => { type => 'arrayref', optional => 1 },
124: }
125:
126: =head4 OUTPUT
127:
128: { type => 'object', isa => 'App::FileSync::Transport::SSH' }
129:
130: =head3 MESSAGES
131:
132: Key Meaning Resolution
133: transport.missing server, repo or client absent fix the repo config
134: transport.bad_value a value is unsafe or out of range fix the repo config or settings
135: transport.bad_id the repo or client is not a plain id fix the repo config
136: io.write the error file cannot be created check the temp directory
137:
138: =head3 FORMAL SPECIFICATION
139:
140: pre server ∈ SERVER ∧ repo ∈ Id ∧ client ∈ Id ∧ role ∈ ROLES ∧ program ∈ PROGRAM
141: ∧ (port = ⊥ ∨ 0 < port ≤ 65535) ∧ ∀ a : extra_args • a ∈ TEXT ∧ '\n' ∉ a
142: argv = ⟨ssh⟩ ⁀ options ⁀ ⟨server, program, --repo, repo, --client, client, --role, role, --proto, PROTO⟩
143:
144: =head3 PSEUDOCODE
145:
146: validate every argument
147: build ssh's options: fixed ones, host key policy, known hosts, identity,
148: port, extra arguments
149: append the server, then the remote command
150: wrap a .cmd/.bat ssh in COMSPEC on Windows
151: start it with standard error going to a temporary file
152:
153: =cut
154:
155: sub new {
156: my $class = shift;
157: my $args = named(\@_, {
158: map({ $_ => { type => 'string', optional => 1 } }
159: qw(server repo client role server_command host_key_checking known_hosts identity port command)),
160: extra_args => { type => 'arrayref', optional => 1 },
161: }, 'Transport::SSH->new');
162:
163: for my $required (qw(server repo client)) {
164: throw('transport.missing', { transport => 'SSH', what => $required })
165: unless defined $args->{$required} && length $args->{$required};
166: }
167: _check('server', $args->{server}, valid_server($args->{server}));
168:
169: for my $check ([ repo => \&validate_repo_name ], [ client => \&validate_client_id ]) {
170: my ($field, $validate) = @{$check};
171: my ($ok, $reason) = $validate->($args->{$field});
172: throw('transport.bad_id', { reason => $reason }) unless $ok;
173: }
174:
175: my $role = $args->{role} || $ROLE_CLIENT;
176: _check('role', $role, any { $_ eq $role } @ROLES);
177:
178: my $program = _given($args->{server_command}) // $SERVER_PROGRAM;
179: _check('server_command', $program, valid_program($program));
180:
181: my $checking = _given($args->{host_key_checking}) // $HOST_KEY_CHECKING[0];
182: _check('host_key_checking', $checking, any { $_ eq $checking } @HOST_KEY_CHECKING);
183:
184: my @command = (_given($args->{command}) // 'ssh', @SSH_OPTIONS, '-o', "StrictHostKeyChecking=$checking");
185:
186: if (defined(my $known = _given($args->{known_hosts}))) {
187: _check('known_hosts', $known, $known !~ $UNSAFE_ARG);
188: push @command, '-o', "UserKnownHostsFile=$known";
189: }
190: if (defined(my $identity = _given($args->{identity}))) {
191: _check('identity', $identity, $identity !~ $UNSAFE_ARG);
192: push @command, '-i', $identity;
193: }
194: if (defined(my $port = _given($args->{port}))) {
195: _check('port', $port, $port =~ /\A\d{1,5}\z/ && $port > 0 && $port <= $MAX_PORT);
196: push @command, '-p', $port;
197: }
198: for my $extra (@{ $args->{extra_args} || [] }) {
199: _check('extra_args', $extra // '', defined $extra && !ref $extra && $extra !~ $UNSAFE_ARG);
200: push @command, $extra;
201: }
202:
203: # The remote shell splits this back into arguments; every value is
204: # restricted (above) to characters that are inert in a POSIX shell.
205: push @command, $args->{server}, $program,
206: '--repo', $args->{repo}, '--client', $args->{client}, '--role', $role, '--proto', $PROTO;
207:
208: if ($^O eq 'MSWin32' && $command[0] =~ /\.(?:cmd|bat)\z/i) {
209: unshift @command, _given($ENV{COMSPEC}) // 'cmd.exe', '/d', '/c';
210: }
211:
212: return bless { command => \@command, status => undef, stderr => '', %{ _spawn(\@command) } }, $class;
213: }
214:
215: =head2 reader
216:
217: Documented with L</exit_status> below.
218:
219: =head2 writer
220:
221: Documented with L</exit_status> below.
222:
223: =head2 command
224:
225: Documented with L</exit_status> below.
226:
227: =head2 exit_status
228:
229: Purpose: the session's pipes, the argv that was run, and ssh's exit status.
230:
231: Args: none.
232:
233: Returns: the read and write handles; a copy of the argv (for C<--verbose> and
234: tests); the exit status after L</close> (undef before).
235:
236: Side Effects: none.
237:
238: Usage:
239:
240: my $argv = $transport->command;
241:
242: =head3 EXAMPLE
243:
244: print "ran: @{ $transport->command }\n";
245:
246: =head3 API SPECIFICATION
247:
248: =head4 INPUT
249:
250: [ { name => 'self', type => 'object' } ]
251:
252: =head4 OUTPUT
253:
254: { type => 'scalar' }
255:
256: =head3 MESSAGES
257:
258: None.
259:
260: =head3 FORMAL SPECIFICATION
261:
262: command = copy(self.command) ; exit_status = self.status
263:
264: =cut
265:
266: sub reader {
267: my ($self) = @_;
268:
269: return $self->{reader};
270: ◆} 271: ◆ 272: ◆sub writer { 273: ◆ my ($self) = @_; 274: ◆ 275: ◆ return $self->{writer}; 276: ◆} 277: ◆ 278: ◆sub command { 279: ◆ my ($self) = @_; 280:
281: return [ @{ $self->{command} } ];
282: }
283:
284: sub exit_status {
285: my ($self) = @_;
286:
287: return $self->{status};
288: }
289:
290: =head2 close
291:
292: Purpose: end the ssh session.
293:
294: Args: none.
295:
296: Returns: 1 when ssh exited 0, else 0. Repeated calls return 1.
297:
298: Side Effects: closes both pipes, reaps ssh, records its exit status and
299: signal, and reads what it wrote to standard error.
300:
301: Usage:
302:
303: $transport->close or warn $transport->error_text, "\n";
304:
305: =head3 EXAMPLE
306:
307: unless ($transport->close) {
308: printf "ssh exited %d: %s\n", $transport->exit_status, $transport->error_text;
309: }
310:
311: =head3 API SPECIFICATION
312:
313: =head4 INPUT
314:
315: [ { name => 'self', type => 'object' } ]
316:
317: =head4 OUTPUT
318:
319: { type => 'integer', memberof => [ 0, 1 ] }
320:
321: =head3 MESSAGES
322:
323: None.
324:
325: =head3 FORMAL SPECIFICATION
326:
327: close = 1 ⇔ closed ∨ exit(ssh) = 0
328:
329: =cut
330:
331: sub close { ## no critic (Subroutines::ProhibitBuiltinHomonyms, Subroutines::ProhibitAmbiguousNames) -- transport interface
332: my ($self) = @_;
333:
334: return 1 if $self->{closed}++;
335:
336: for my $handle (grep { defined } @{$self}{qw(writer reader)}) {
337: CORE::close($handle);
338: }
339:
340: if ($self->{pid}) {
341: waitpid($self->{pid}, 0);
342: my $status = $?;
343: @{$self}{qw(status signal pid)} = ($status >> 8, $status & 127, 0);
344: }
345: $self->{stderr} = _slurp($self->{error_path});
346:
347: return ($self->{status} || 0) == 0 ? 1 : 0;
348: }
349:
350: =head2 error_text
351:
352: Purpose: what ssh or the remote shell said, for when the protocol failed.
353:
354: Args: none.
355:
356: Returns: the text, trimmed, with blank lines collapsed.
357:
358: Side Effects: reads the error file if L</close> has not yet.
359:
360: Usage:
361:
362: my $why = $transport->error_text;
363:
364: =head3 EXAMPLE
365:
366: print $transport->error_text, "\n"; # "Permission denied (publickey)."
367:
368: =head3 API SPECIFICATION
369:
370: =head4 INPUT
371:
372: [ { name => 'self', type => 'object' } ]
373:
374: =head4 OUTPUT
375:
376: { type => 'string' }
377:
378: =head3 MESSAGES
379:
380: None.
381:
382: =head3 FORMAL SPECIFICATION
383:
384: error_text = squeeze(trim(stderr))
385:
386: =cut
387:
388: sub error_text {
389: my ($self) = @_;
390:
391: my $text = length $self->{stderr} ? $self->{stderr} : _slurp($self->{error_path});
392: $text =~ s/\A\s+|\s+\z//g;
393: $text =~ s/\n+/\n/g;
394: return $text;
395: }
396:
397: =head2 valid_server
398:
399: Documented with L</valid_program> below.
400:
401: =head2 valid_program
402:
403: Purpose: check a server address and a remote program path.
404:
405: Args: the value.
406:
407: Returns: 1 or 0.
408:
409: A server is C<user@host>, C<host> or C<user@[ipv6]>; the user and host must
410: start with a letter or digit, so neither can be read as an ssh option (a
411: leading C<->) and nothing can split into another word. A program is a path of
412: letters, digits, C<.>, C<_>, C</> and C<->, not starting with C<->.
413:
414: Side Effects: none.
415:
416: Usage:
417:
418: die "bad server\n" unless App::FileSync::Transport::SSH::valid_server($server);
419:
420: =head3 EXAMPLE
421:
422: App::FileSync::Transport::SSH::valid_server('filesync@files.example.com'); # 1
423: App::FileSync::Transport::SSH::valid_server('-oProxyCommand=sh'); # 0
424: App::FileSync::Transport::SSH::valid_server('-v@host'); # 0
425:
426: =head3 API SPECIFICATION
427:
428: =head4 INPUT
429:
430: [ { name => 'value', type => 'string', optional => 1 } ]
431:
432: =head4 OUTPUT
433:
434: { type => 'integer', memberof => [ 0, 1 ] }
435:
436: =head3 MESSAGES
437:
438: None.
439:
440: =head3 FORMAL SPECIFICATION
441:
442: valid_server(v) ⇔ v ∈ SERVER
443: valid_program(v) ⇔ v ∈ PROGRAM
444:
445: =cut
446:
447: sub valid_server {
448: my ($value) = @_;
449:
450: return (defined $value && $value =~ $SERVER) ? 1 : 0;
451: }
452:
453: sub valid_program {
454: my ($value) = @_;
455:
456: return (defined $value && $value =~ $PROGRAM) ? 1 : 0;
457: }
458:
459: # _spawn
460: # Purpose: start ssh with stderr going to a temporary file.
461: # Entry: $command is the full argv.
462: # Exit: returns { pid, writer, reader, errors, error_path }.
463: # Side effects: creates the error file (removed when the object goes) and
464: # starts the process. IPC::Open3 rather than fork/exec: on
465: # Windows fork() is a pseudo-process whose pipe handles are
466: # not always duplicated, which leaves a full-duplex session
467: # waiting on a pipe end that never closes.
468: sub _spawn :Private {
469: my ($command) = @_;
470:
471: my $errors = File::Temp->new(UNLINK => 1);
472: my $error_path = $errors->filename;
473: open my $err_fh, '>', $error_path;
474:
475: my ($writer, $reader);
476: my $pid = IPC::Open3::open3($writer, $reader, '>&' . fileno($err_fh), @{$command});
477: CORE::close($err_fh);
478:
479: return { pid => $pid, writer => $writer, reader => $reader, errors => $errors, error_path => $error_path };
480: }
481:
482: # _check
483: # Purpose: refuse an unsafe or out-of-range argument.
484: # Entry: $ok is the result of the check.
485: # Exit: returns 1.
486: # Side effects: raises transport.bad_value naming the field.
487: sub _check :Private {
488: my ($field, $value, $ok) = @_;
489:
490: throw('transport.bad_value', { field => $field, value => $value }) unless $ok;
491: return 1;
492: }
493:
494: # _given
495: # Purpose: treat an empty string like an absent value.
496: # Entry: any scalar.
497: # Exit: returns the value, or undef if undefined or empty.
498: # Side effects: none.
499: sub _given :Private {
500: my ($value) = @_;
501:
502: return (defined $value && length $value) ? $value : undef;
503: }
504:
505: # _slurp
506: # Purpose: the error file's contents.
507: # Entry: $path may be undef or gone.
508: # Exit: returns the text, or ''.
509: # Side effects: reads the file; an unreadable one is treated as empty
510: # (there is nothing better to report).
511: sub _slurp :Private {
512: my ($path) = @_;
513:
514: return '' unless defined $path && -e $path;
515: my $text = eval { read_text($path) };
516: return defined $text ? $text : '';
517: }
518:
519: 1;
520:
521: __END__
522:
523: =head1 LIMITATIONS
524:
525: =over 4
526:
527: =item * C<extra_args> are passed to ssh unchecked apart from embedded NULs and
528: newlines: they are the user's own options, and can therefore do anything ssh
529: options can (C<-o ProxyCommand=...> included). Only trusted configuration
530: should set them.
531:
532: =item * C<known_hosts> and C<identity> are not tilde-expanded here; ssh expands
533: C<~> in C<-i> but not in C<UserKnownHostsFile> on every version.
534:
535: =back
536:
537: =head1 AUTHOR
538:
539: Nigel Horne, C<< <njh at nigelhorne.com> >>
540:
541: =head1 LICENCE AND COPYRIGHT
542:
543: Copyright 2026 Nigel Horne.
544:
545: Usage is subject to the GPL2 licence terms.
546: If you use it,
547: please let me know.
548:
549: =cut